Sub EinlesenDateienInEineGesamtTabelle()Code eingefügt mit Syntaxhighlighter 1.14
Dim i_Zeile As Integer
Dim i_Datei As Integer
Dim s_Mappe As String
Dim s_Tabelle As String
Dim i_Satzzähler As Integer
Dim s_Monat As String
s_Mappe = ThisWorkbook.Name
s_Tabelle = "Zusammenfassung"
With Workbooks(s_Mappe).Sheets(s_Tabelle)
.Cells(1, 1).Value = "Datum"
.Cells(1, 2).Value = "Umsatz"
.Cells(1, 3).Value = "Region"
.Cells(1, 4).Value = "Monat"
End With
i_Zeile = 2
Application.ScreenUpdating = False
'Eingabedateien ermitteln
With Application.FileSearch
.Filename = "*.xls"
.LookIn = "D:\Test\"
.SearchSubFolders = False
.Execute
For i_Datei = 1 To .FoundFiles.Count
Workbooks.Open (.FoundFiles(i_Datei))
'Monat ermitteln
If InStr(ActiveWorkbook.Name, "Jan") > 0 Then s_Monat = "Januar"
If InStr(ActiveWorkbook.Name, "Feb") > 0 Then s_Monat = "Februar"
If InStr(ActiveWorkbook.Name, "Mär") > 0 Then s_Monat = "März"
If InStr(ActiveWorkbook.Name, "Apr") > 0 Then s_Monat = "April"
If InStr(ActiveWorkbook.Name, "Jun") > 0 Then s_Monat = "Juni"
If InStr(ActiveWorkbook.Name, "Jul") > 0 Then s_Monat = "Juli"
If InStr(ActiveWorkbook.Name, "Aug") > 0 Then s_Monat = "August"
If InStr(ActiveWorkbook.Name, "Sep") > 0 Then s_Monat = "September"
If InStr(ActiveWorkbook.Name, "Okt") > 0 Then s_Monat = "Oktober"
If InStr(ActiveWorkbook.Name, "Nov") > 0 Then s_Monat = "November"
If InStr(ActiveWorkbook.Name, "Dez") > 0 Then s_Monat = "Dezember"
'Einzelne Sätze übertragen
For i_Satzzähler = 2 To ActiveSheet.UsedRange.Rows.Count
With Workbooks(s_Mappe).Sheets(s_Tabelle)
.Cells(i_Zeile, 1).Value = ActiveSheet.Cells(i_Satzzähler, 1).Value
.Cells(i_Zeile, 2).Value = ActiveSheet.Cells(i_Satzzähler, 2).Value
.Cells(i_Zeile, 3).Value = Left(ActiveWorkbook.Name, 1)
.Cells(i_Zeile, 4).Value = s_Monat
End With
i_Zeile = i_Zeile + 1
Next i_Satzzähler
ActiveWorkbook.Close
Next i_Datei
End With
'Nach Datum sortieren
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.ScreenUpdating = True
End Sub
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen