Option Explicit
' ************************************************************************************************
' Autor/en: http://www.online-vba.de - Marc Wershoven
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von www.online-vba.de!
' Original-Quelltext: www.online-vba.de/vba_datensammeln3.php
' ************************************************************************************************

'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.

Sub MWSheetsAusMehrerenDateienEinlesen()
   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 und 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