Option Explicit
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_datensammeln.php
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.online-vba.de
' ****************************************************************
Public Sub OVBAde_DatenAusMehrerenDateienEinlesen()
Dim oTargetSheet As Object
Dim oSourceBook As Object
Dim sPfad As String
Dim sDatei As String
Dim lErgebnisZeile As Long
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
'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
'Datenübertragung
'Spalte 1 - Dateinamen
oTargetSheet.Cells(lErgebnisZeile, 1).Value = sDatei
'Spalte 2 - Zelleninhalt A1 vom Arbeitsblatt "Tabelle1"
oTargetSheet.Cells(lErgebnisZeile, 2).Value = _
oSourceBook.Sheets("Tabelle1").Cells(1, 1).Value
'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde
oSourceBook.Close False 'nicht speichern
'Nächste Datei
sDatei = Dir()
lErgebnisZeile = lErgebnisZeile + 1 'nächste Zeile auf dem Ergebnisblatt
Loop
Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub