mehrer Excel Tabellen mit mehreren Blättern zusammenführen

Option Explicit

Sub Sammle()
Const sSourcePath As String = "D:\Viele viele XLS"  
Dim wbGes As Workbook, wsTarget As Worksheet
Dim wbTeil As Workbook, wsSource As Worksheet
Dim fso As Object, oFile As Object
Dim rNext As Integer, bSheetFound As Boolean
Set wbGes = ActiveWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")  

'Quell-Ordner durchsuchen  
For Each oFile In fso.GetFolder(sSourcePath).Files
    'nur .xls-Dateien bearbeiten  
    If LCase(Right(oFile.Name, 4)) = ".xls" Then  
        Application.Workbooks.Open (oFile.Path)
        Set wbTeil = ActiveWorkbook
        'alle Tabellen der Gesamt-Datei bearbeiten  
        For Each wsTarget In wbGes.Worksheets
            'Tabelle auch in Teil-Datei enthalten?  
            For Each wsSource In wbTeil.Worksheets
                bSheetFound = False
                If LCase(wsTarget.Name) = LCase(wsSource.Name) Then
                    bSheetFound = True
                    Exit For
                End If
            Next
            If bSheetFound Then
                'Tabelle da, Daten kopieren ...  
                wbTeil.Worksheets(wsTarget.Name).Activate
                Range("A1").Select  
                Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Copy
                '... und einfügen in Gesamt-Datei-Tabelle...  
                wbGes.Worksheets(wsTarget.Name).Activate
                '... ab der nächsten freien Zeile  
                rNext = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
                ActiveSheet.Cells(rNext, 1).Activate
                ActiveSheet.Paste
                Application.CutCopyMode = False
            End If
        Next 'Tabelle  
        wbTeil.Close
    End If
Next 'Datei  
wbGes.Worksheets(1).Activate
'Gesamt-Datei speichern  
wbGes.Save
MsgBox "Fertig."  
End Sub