Mehrere CSV-Dateien in ein Excel spielen
08.04.2014 12:40:16
TomTurbo
Ich hab folgendes Problem: Ich möchte viele csv-Dateien in ein großes Excel 1 zu 1 einspielen.
Dabei muss jede einzuspielende CSV Datei in eine neues Register im großen Excel eingebunden werden.
Ich habs soweit geschafft, dass ich gleich einen ganzen ordner mit csv dateien einlese, jedoch es nicht schaffe, die reiter mit den passenden namen zu versehen (aus dem csv namen will ich mir einen teil rausparsen)... kann mir da jemand weiterhelfen?
danke lg
Private Sub ImportiereCSVDateien()
Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet
Dim fso, i, f, fd
Set fso = CreateObject("Scripting.Filesystemobject")
Set wbTarget = ActiveWorkbook
Dim BrowseDir As Object
On Error GoTo Err
Set BrowseDir = CreateObject("Shell.Application").BrowseForFolder(0, "Ordner auswählen", & _
H4000, 17)
Application.DisplayAlerts = False
For Each f In fso.GetFolder(BrowseDir.self.Path).Files
If LCase(Right(f.Name, 3)) = "csv" Then
Workbooks.OpenText Filename:=f.Path
Set wbSource = ActiveWorkbook
On Error Resume Next
Set ws = wbTarget.Worksheets(f.Name)
If Err 0 Then
Set ws = wbTarget.Worksheets.Add
ws.Name = f.Name
ws.Range("A:ZZ").Clear
End If
wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True
wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1")
wbSource.Close False
End If
Next
Application.DisplayAlerts = True
Set fso = Nothing
Err:
Call MsgBox("ENDE", vbExclamation, "Programm Beendet")
End Sub