Mehrere .csv Dateien in Spaltenform importieren
Matthias
Ramses hatte im November 2006 das untenstehende Makro veröffentlicht, das mehrere .csv-Dateien gleichzeitig importiert (Link: https://www.herber.de/forum/archiv/820to824/t822222.htm)
In diesem Makro werden die Inhalte der csv-Dateien untereinander angehängt.
Wie muß ich das Makro abändern, damit die Inhalte nebeneinander importiert werden ?
(also Inhalt von Datei1 in Spalte 1-3, Inhalt von Datei2 in Spalte 4-6, Inhalt von Datei3 in Spalte 7-9 usw.)
Was muß geändert werden, damit zusätzlich in die erste Zeile immer der Name der importierten csv-Datei erscheint ?
(in A1 steht Dateiname1, in A4 der Dateiname2, in A7 der Dateiname3 usw.)
Vielen Dank, Matthias
Option Explicit
Sub Rename_Files()
'(C) Ramses
'Liest alle CSV-Dateien in einem Verzeichnis ein
Dim Datei As String, freeRow As Long
Dim Qe As Integer
Dim PFAD As String
PFAD = "c:\" 'ACHTUNG: Bachslash am Schluss
Datei = Dir(PFAD & "*.csv")
Qe = MsgBox("Zum Import muss die aktuelle Tabelle leer sein," & vbCrLf & _
"bzw. alle Daten der aktuellen Tabelle: "" " & ActiveSheet.Name & " "" werden gelöscht", _
vbYesNo + vbCritical, "CSV-Import starten ?")
If Qe = vbNo Then
MsgBox "CSV-Import abgebrochen"
Exit Sub
Else
Cells.Clear
End If
Do While Datei ""
freeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & PFAD & Datei, Destination:=Range("A" _
_
_
& freeRow))
.Name = Datei
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Datei = Dir()
Loop
End Sub