|
Dim fso As Object
Sub ImportData()
Dim col As New Collection, file As Variant, wb As Workbook, rngDest As Range
'Ordner der die Dateien enthält
Const FOLDER = "C:\Users\***\Desktop\test auslesen"
'Filesystemobject
Set fso = CreateObject("Scripting.FileSystemObject")
'alle Excel-Dateien rekursiv listen
getAllFiles fso.GetFolder(FOLDER), True, Array("xlsx", "xls"), col
'Screenupdates und eventuelle Dialoge für Batchbetrieb unterdrücken
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Sheets(1)
'nächste freie Zelle in Spalte A ermitteln
Set rngDest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
'Für jede Excel-Datei
For Each file In col
'Workbook öffnen
Set wb = Workbooks.Open(file)
'Range B20:B21 ins Sheet kopieren
wb.Sheets(1).Range("C2").Copy rngDest
wb.Sheets(2).Range("D4:D41").Copy rngDest
wb.Sheets(3).Range("F4:F41").Copy rngDest
wb.Sheets(4).Range("G4:G41").Copy rngDest
wb.Sheets(5).Range("H4:H41").Copy rngDest
'WB schließen
wb.Close False
'nächste freie Zelle setzen
Set rngDest = rngDest.Offset(5, 0)
Next
End With
'Screenupdates und Dialoge wieder einschalten
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub getAllFiles(ByVal fldr As Object, boolRecursion As Boolean, arrFileExtensions As Variant, ByRef col As Collection)
For Each file In fldr.Files
For i = 0 To UBound(arrFileExtensions)
If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) Then
col.Add file.Path
Exit For
End If
Next
Next
If boolRecursion Then
For Each subFolder In fldr.SubFolders
getAllFiles subFolder, True, arrFileExtensions, col
Next
End If
End Sub
Das war mal mein Versuch... leider klappt es nicht so wie ich´s mir wünsche. Die Datei soll mit z.B. auf dem Reiter (Tabellenblatt "Auswertung") immer die erste Seite der gefundenen Excel Dateien ausgeben..... Wie kann ich das lösen??
Wichtig, dass immer das Datum aus C2 wieder vor die neue Zeile mit werten wiederholt wird, wenn in den anderen Zeilen werte gefunden werden.
Gruß
|