Werte in Tabellen je Arbeitsmappe in einem Verzeichnis auslesen

Mittels VBA Werte in Tabellen je Arbeitsmappe (Excel Datei) in einem Verzeichnis auslesen und
in einer neuen Tabelle zeilenweise zusammenführen:

--- Code Snippet Begin ---

Sub TabellenAusMehrerenDateienEinlesen()

   Dim oTargetSheet As Object
   Dim wksSheet As Object
   Dim oSourceBook As Object
   Dim sPfad As String
   Dim sDatei As String
   Dim lErgebnisZeile As Long
 
 
   On Error GoTo fehler
 
     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
     
     'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen
     Set oTargetSheet = ActiveWorkbook.Sheets.Add
     lErgebnisZeile = 2 'Ergebnisse eintragen ab Zeile 2
   
     'Spaltenbeschriftungen in Zeile 1
     With oTargetSheet
        .Cells(1, 1) = "Dateiname"
        .Cells(1, 2) = "Tabelle"
        .Cells(1, 3) = "Merkmal1"
        .Cells(1, 4) = "Merkmal2"
        .Cells(1, 5) = "Merkmal3"
        .Cells(1, 6) = "Merkmal4"
        .Cells(1, 7) = "Merkmal5"
        .Cells(1, 8) = "Merkmal6"
        .Cells(1, 9) = "MerkmalN"
    End With
   
   
     'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis
     'Verzeichnispfad steht in Tabelle Dokumentation, Spalte B1
     'zB D:\Projekte\
     'oder alternativ hart codiert
     'sPfad = "D:\Projekte\"
     sPfad = ActiveWorkbook.Worksheets("Dokumentation").Cells(1, 2).Value
     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
       
         'Datenübertragung genutzten Spalten selektiv

             'Durchlaufe alle Tabellen der Excel Datei
             For Each wksSheet In oSourceBook.Worksheets
           
                'Daten nur übernehmen, wenn in Zelle A1 der Tabelle ein Wert steht
                If Trim(CStr(wksSheet.Cells(1, 1).Value)) <> "" Then
                     
                            With oTargetSheet 'Zuweisung Wert zu Ergebniszeile
                                 .Cells(lErgebnisZeile, 1).Value = sDatei
                                 .Cells(lErgebnisZeile, 2).Value = wksSheet.Name
                                 .Cells(lErgebnisZeile, 3).Value = wksSheet.Cells(1, 16)
                                 .Cells(lErgebnisZeile, 4).Value = wksSheet.Cells(2, 16)
                                 .Cells(lErgebnisZeile, 5).Value = wksSheet.Cells(3, 16)
                                 .Cells(lErgebnisZeile, 6).Value = wksSheet.Cells(4, 16)
                                 .Cells(lErgebnisZeile, 7).Value = wksSheet.Cells(6, 16)
                                 .Cells(lErgebnisZeile, 8).Value = wksSheet.Cells(7, 16)
                                 .Cells(lErgebnisZeile, 9).Value = wksSheet.Cells(8, 16)
                            End With
                         
                            lErgebnisZeile = lErgebnisZeile + 1
                End If
             
             Next
       
         'Schritt 4: Datei wieder schließen und nächste Schleifenrunde
         oSourceBook.Close False 'nicht speichern
       
         'Nächste Datei
         sDatei = Dir()
     Loop
   
     'Spalten ausrichten
     oTargetSheet.Range("A1:I1").Columns.AutoFit
   
     Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
   
     'Variablen aufräumen
     Set oTargetSheet = Nothing
     Set oSourceBook = Nothing
   
Exit Sub
   
fehler:
     Call MsgBox("Ein Fehler ist aufgetreten", vbInformation)
   
End Sub

-- Code Snippet Ende

siehe auch Alternative mit Excel Power Query