Tabellen aus Unterordnern zusammenfassen

Sub DatenAktualisieren()
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim PfadQuelle As String, strQuelle As String
Dim wbZiel As Workbook, arrWksZiel() As Worksheet, intI As Integer, intArr As Integer
Dim ZeileQuelle As Long, ZeileZiel As Long, Spalte As Long
Dim wksSt As Worksheet, SpalteDatei As Long
On Error GoTo Fehler
Set wbZiel = ActiveWorkbook
Set wksSt = wbZiel.Worksheets("Steuerung")
Application.ScreenUpdating = False
SpalteDatei = wksSt.Range("A11").Value 'Nummer der Spalte in der ggf. Dateiname eingetragen   _
_
wird
With wbZiel
'zu vergleichende Worksheet-Objekte dem Array zuweisen
intArr = 0
For intI = 1 To .Worksheets.Count
With .Worksheets(intI)
Select Case .Name
Case wksSt.Range("A17"), wksSt.Range("A18"), wksSt.Range("A19"), _
wksSt.Range("A20"), wksSt.Range("A21"), wksSt.Range("A22")
'Name(n) der Blätter, die in Zusammenfassung nicht _
aktualisiert werden sollen
Case Else
'Array mit den abzugleichendne Tabellenblättern redimensionieren
intArr = intArr + 1
ReDim Preserve arrWksZiel(1 To intArr)
'Worksheet-Objekt zuweisen
Set arrWksZiel(intArr) = wbZiel.Worksheets(intI)
'vorhandene Alt-Daten in den Tabellenblättern löschen
.Range(.Cells(3, 1), .Cells(.Rows.Count, 33)).ClearContents
' If .Cells(.Rows.Count, 2).End(xlUp).Row >= 32 Then
'If SpalteDatei > 0 Then
' .Cells(3, SpalteDatei).Value = "Dateiname"
'End If
' .Range(.Rows(2), .Rows(.Cells(.Rows.Count, 2).End(xlUp).Row)).ClearContents
'End If
End Select
End With
Next
End With
'Verzeichnis mit den Quelldaten festlegen
If wksSt.Range("A14")  "" Then
PfadQuelle = wksSt.Range("A14")
Else
PfadQuelle = wbZiel.Path              'orig
End If
'Dateinamen in Pfad abarbeiten
strQuelle = Dir(PfadQuelle & Application.PathSeparator & "*.xl*")   'orig
intArr = 0
Do Until strQuelle = ""
Select Case LCase(strQuelle)
Case LCase(wbZiel.Name), LCase(wksSt.Range("A25")), LCase(wksSt.Range("A26")), _
LCase(wksSt.Range("A27")) 'Liste ggf. anpassen/ergänzen
'diese Dateien beim Auslesen überspringen
Case Else
'Quelldatei öffnen
Set wbQuelle = Workbooks.Open( _
Filename:=PfadQuelle & Application.PathSeparator & strQuelle, _
ReadOnly:=False, _
UpdateLinks:=True)
intArr = intArr + 1
Application.StatusBar = "DateiNummer " & Format(intArr, "000") _
& " wird bearbeitet"
'Tabellenblätter in Quelle abarbeiten
For intI = 1 To 1 'UBound(arrWksZiel)
Set wksQuelle = wbQuelle.Worksheets(arrWksZiel(intI).Name)
With wksQuelle
'Prüfen, Daten ab Zeile 3 vorhanden
If .Cells(.Rows.Count, 2).End(xlUp).Row >= 3 Then
'Daten in Zusammenfassung einfügen
For ZeileQuelle = 3 To .Cells(.Rows.Count, 2).End(xlUp).Row
With arrWksZiel(intI)
ZeileZiel = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
For Spalte = 2 To 33
.Cells(ZeileZiel, Spalte).Value = _
wksQuelle.Cells(ZeileQuelle, Spalte).Value
Next
'ggf. den Dateinamen der Quelle eintragen
If SpalteDatei  0 Then
.Cells(ZeileZiel, SpalteDatei).Value = wbQuelle.Name
End If
End With
Next
End If
End With
Resume_Next_Sheet:
Next
'Quelldatei wieder schliessen - inklusive speichern
Application.DisplayAlerts = False
wbQuelle.Close savechanges:=True
Set wbQuelle = Nothing
Application.DisplayAlerts = True
End Select
'Namen der nächste Quelldatei einlesen
strQuelle = Dir
Loop
Application.ScreenUpdating = True
'Aktualisierungsdatum im Blatt Steuerung eintragen
wksSt.Range("C8").Value = Now
MsgBox "Fertig" & vbLf & vbLf & intArr & "  Dateien eingelesen"
Fehler:
With Err
Select Case .Number
Case 0 'kein Fehler
Case 9 'Tabellenblatt in Quelle nicht gefunden
Resume Resume_Next_Sheet
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
If Not wbQuelle Is Nothing Then
Application.DisplayAlerts = False
wbQuelle.Close savechanges:=True
Set wbQuelle = Nothing
Application.DisplayAlerts = True
End If
Set wbZiel = Nothing: Set wksSt = Nothing: Set wksQuelle = Nothing
ReDim arrWksZiel(1 To 1)
End Sub