AW: Viele CSV bzw. xl-Files in einem File zusammenfüge
21.03.2007 16:01:28
Rudi
Hallo,
da weigere ich mich aber, sowas einzubauen. ;-) Das geht besser.
Sub CSVzusammenfuegen()
Dim FS As Object, oFolder As Object, oFile As Object
Dim vntTemp, strTemp As String
Dim wkbCSV As Workbook, wksCSV As Worksheet
Dim blnHeader As Boolean, blnFirstRow As Boolean
Dim strCsvPath As String, strDateiName As Variant
Dim lngLastRow As Long
Const strDelim As String = ";" 'Trennzeichen
'Ordner wählen
With Application.FileDialog(4)
.InitialFileName = "C:\"
.InitialView = 2
.Title = "Bitte einen Ordner wählen"
If .Show = -1 Then
strCsvPath = .SelectedItems(1)
End If
End With
If strCsvPath = "" Then Exit Sub
If Dir(strCsvPath & "\*.csv", vbNormal) = "" Then
MsgBox "Keine .CSV im Ordner."
Exit Sub
End If
Set wkbCSV = Workbooks.Add(1)
Set wksCSV = wkbCSV.Sheets(1)
wksCSV.Cells.Clear
Set FS = CreateObject("scripting.filesystemobject")
Set oFolder = FS.getfolder(strCsvPath)
For Each oFile In oFolder.Files
If oFile.Name Like "*.csv" Then
Open oFile For Input As #1
blnFirstRow = True
Do While Not EOF(1)
Line Input #1, strTemp
vntTemp = Split(strTemp, strDelim)
With wksCSV
If UBound(vntTemp) > -1 Then
If blnHeader = False Or blnFirstRow = False Then
.Range(.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0), .Cells(Rows.Count, 1). _
End(xlUp).Offset(1, UBound(vntTemp))) = vntTemp
blnHeader = True
End If
End If
End With
blnFirstRow = False
Loop
Close 1
End If
Next oFile
Set oFolder = Nothing
Set FS = Nothing
With wksCSV
.Rows(1).Delete
lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Columns(3).Insert Shift:=xlToRight
.Range("C1") = "FILTER_TYP"
.Range(.Cells(2, 3), .Cells(lngLastRow, 3)).FormulaR1C1 = "=MID(RC[-1],7,5)"
.Range(.Cells(2, 3), .Cells(lngLastRow, 3)) = .Range(.Cells(2, 3), .Cells(lngLastRow, 3)). _
Value
.Name = "Gesamt_CSV"
End With
'Datei speichern
strDateiName = Application.GetSaveAsFilename("gesamt_CSV", "Microsoft-Excel Arbeitsmappe (*. _
xls),*.xls", , "Datei speichern unter")
If strDateiName False Then wkbCSV.SaveAs strDateiName
End Sub
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe