Viele Excel-Dateien zusammenführen

Sub zusammen()

Dim fs As Object
Dim fVerz As Object
Dim fDatei As Object
Dim fdateien As Object
Dim monate(1 To 12) As String
Dim zeile As Integer

zeile = 1 ' Ab welcher Zeile sollen die Daten hier eingefügt werden (Vorsicht, die werden überschrieben bei mehrmaliger Ausführung)  

' Liste der auszulesenden Registerkarten der Quelldateien (alle anderen werden ignoriert!)  
monate(1) = "Jan"  
monate(2) = "Feb"  
monate(3) = "März"  
monate(4) = "April"  
monate(5) = "Mai"  
monate(6) = "Juni"  
monate(7) = "Juli"  
monate(8) = "Aug"  
monate(9) = "Sept"  
monate(10) = "Okt"  
monate(11) = "Nov"  
monate(12) = "Dez"  

Pfad = InputBox("Pfad zu Quelldateien eingeben:", "Pfad Quelldateien", "C:\")  

Application.ScreenUpdating = False 'dient dazu, dass der Bildschirm nicht ständig flackert, wenn zwischen den Excel-Listen umgeschaltet wird (macht das Programm schneller)  

Set fs = CreateObject("scripting.FileSystemObject")  
Set fVerz = fs.getFolder(Pfad) ' Pfad mit einzufügenden Excels einlesen  
Set fdateien = fVerz.Files

Set Liste_Einfügen = ActiveWorkbook ' in aktuelles Excel einfügen  

For Each fDatei In fdateien ' Alle Dateien im Verzeichnis  
    Set Liste_Auslesen = Application.Workbooks.Open(fDatei)
    Liste_Auslesen.Activate
    For Each monat In monate ' Die im Array monate definierten Registerkarten durchgehen  
        Sheets(monat).Select
        For iZähler = 10 To 23 ' relevante Zeilen durchgehen  
            If Worksheets(ActiveSheet.Name).Cells(iZähler, 1).Value <> "" Then  
                For jZähler = 2 To 32 ' Spalte 2 bis 32 überprüfen  
                    If Worksheets(ActiveSheet.Name).Cells(iZähler, jZähler).Value <> "" And Worksheets(ActiveSheet.Name).Cells(iZähler, jZähler).Value <> "0" Then ' Nur wenn ein Wert drin steht  
                        zeile = zeile + 1
                        ' Alle Daten aus Quelldatei kopieren und hier einfügen:  
                        ' Jahr  
                        Range("Q5").Select  
                        Selection.Copy
                        Liste_Einfügen.Activate
                        Cells(zeile, 1).Select
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Liste_Auslesen.Activate
                        ' Monat  
                        Range("Q4").Select  
                        Selection.Copy
                        Liste_Einfügen.Activate
                        Cells(zeile, 2).Select
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Liste_Auslesen.Activate
                        ' Tag  
                        Cells(9, jZähler).Select
                        Selection.Copy
                        Liste_Einfügen.Activate
                        Cells(zeile, 3).Select
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Liste_Auslesen.Activate
                        ' Daten 1  
                        Range("C3").Select  
                        Selection.Copy
                        Liste_Einfügen.Activate
                        Cells(zeile, 4).Select
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Liste_Auslesen.Activate
                        ' Daten 2  
                        Range("C5").Select  
                        Selection.Copy
                        Liste_Einfügen.Activate
                        Cells(zeile, 5).Select
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        Liste_Auslesen.Activate
                      End If
                Next
            End If
        Next
    Next monat
    ActiveWorkbook.Close savechanges:=False
Next fDatei

Application.ScreenUpdating = True
End Sub