Sheets aus Dateien sammeln

Option Explicit
' Original-Quelltext unter: https://www.online-vba.de/sheets-aus-dateien-sammeln
' Express-Hilfe für VBA unter https://www.online-vba.de/vba-expresshilfe
' Es gelten die Nutzungsbedingungen von Online-VBA.de

'Hinweise: Die Zieldatei darf nicht im gleichen Verzeichnis sein, wie die einzulesenden Dateien.
'Das Beispielmakro importiert immer das erste Arbeitsblatt von allen Dateien, die im
'angegebenen Verzeichnis enthalten sind. Diese Arbeitsblätter werden in die Arbeitsmappe
'eingefügt, in der sich das folgende Makro befindet und gestartet wird.
'Die einzulesenden Dateien müssen geschlossen sein.

Public Sub OVBAde_SheetsAusMehrerenDateienEinlesen()
  Dim oTargetBook As Object
  Dim oSourceBook As Object
  Dim sPfad As String
  Dim sDatei As String
    
    Application.ScreenUpdating = False 'Das "Flackern" ausstellen
    Application.DisplayAlerts = False 'Keine Fehlermeldungen anzeigen
    
    'Schritt 1: Arbeitsmappe festlegen, in die die neuen Sheets eingefügt werden ...
    Set oTargetBook = ActiveWorkbook
    
    'Wichtiger Hinweis: Die Arbeitsblätter dürfen nicht vorhanden sein!
    'Alternativer Umbau: Löschen evtl. bereits vorhandener Arbeitsblätter
    
    'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
    sPfad = "C:\TEST\Sammlung\"
    sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien
    
    Do While sDatei <> ""
    
        'Schritt 3: Öffnen der Datei und Datenübertragung
        Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
        
        'Es wird immer das erste Tabellenblatt Sheets(1) kopiert!
        oSourceBook.Sheets(1).Copy after:=oTargetBook.Sheets(oTargetBook.Sheets.Count)
        
        'Es wird versucht, den Dateinamen als Arbeitsblattnamen zu setzen.
        'Ist dieser bereits vorhanden, wird der Fehler abgefangen und das neue Blatt
        'bekommt keinen anderen Namen, sondern behält den typischen Namen Tabelle x
        On Error Resume Next
        
        'Arbeitsblattname wird der Dateiname
        oTargetBook.Sheets(oTargetBook.Sheets.Count).Name = sDatei
        
        'Wenn ein Fehler aufgetreten ist, wird dieser resettet
        If Err.Number <> 0 Then
            Err.Number = 0
            Err.Clear
        End If
        On Error GoTo 0
        
        'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
        oSourceBook.Close False 'nicht speichern
        
        'Nächste Datei
        sDatei = Dir()
    Loop
    
    Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
    Application.DisplayAlerts = True 'Fehlermeldungen wieder anzeigen
    
    'Kleine finale Fertig-Meldung
    MsgBox "Fertig!", vbInformation + vbOKOnly, "Hinweis!"
    
    'Variablen aufräumen
    Set oTargetBook = Nothing
    Set oSourceBook = Nothing
End Sub