Hallo,
ja, jetzt versteh ich das besser. Danke dir :)

Ich habe es mal angepasst und mit Einzeltabellen getestet. Sollte aber auch mit mehreren Tabellen in einer Datei funktionieren.

Gruß

--- Makro ---

Option Explicit

Sub DatenHolen()
    Dim strPfad As String
    Dim strDatei As String
    Dim strExt As String
    
    Dim lngTabMax As Long
    Dim lngTab As Long
    
    Dim lngZmax As Long
    
    Dim WB As Workbook
    Dim WS As Worksheet
    
    Dim wsAusgabe As Worksheet
    
    'Fehlerbehandlung: ist nur das notwendigste
    On Error GoTo Aufräumen
    
    'AusgabeTabelle anpassen
    
    'eine neue Tabelle wird hinzugefügt
'    Set wsAusgabe = ThisWorkbook.Worksheets.Add
    
    'Fester Name
    Set wsAusgabe = ThisWorkbook.Worksheets("Tabelle1")
    
    Dim booAlleTabellen As Boolean
    
    Dim arrBereich As Variant
    Dim arrBereichIndex As Long
    
    Dim arrDaten As Variant
    
    Dim lngArrZmax As Long
    Dim lngArrSmax As Long
    
    'Pfadname anpassen
    strPfad = "C:\temp\test\"
    If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
    
    'Dateiendung anpassen
    strExt = "*.xls*"
        
    'Bereich der zu durchsuchenden Zellen anpassen
    arrBereich = Array("G2", "B6", "B8", "B9", "H8", "M9")
    
    'Anpassen: False = nur erste Tabelle; True = alle Tabellen
    booAlleTabellen = False
    
    If booAlleTabellen = False Then
        lngTabMax = 1
        Else
        lngTabMax = WB.Worksheets.Count
    End If
    
    'Erste Datei suchen
    strDatei = Dir(strPfad & strExt)
    'Solange noch Dateien da sind
    Do While Len(strDatei) > 0
        'Datei öffnen
        Set WB = Workbooks.Open(Filename:=strPfad & strDatei, ReadOnly:=True)
        If Not WB Is Nothing Then
            'Wenn Datei offen dann alle gewünschten
            'Tabellen durchgehen (eine oder alle)
            For lngTab = 1 To lngTabMax
                'Tabelle auswählen
                Set WS = WB.Worksheets(lngTab)
                'Bereich in Variable schreiben
                ReDim arrDaten(UBound(arrBereich))
                
                'alle Werte in Array schreiben
                For arrBereichIndex = LBound(arrBereich) To UBound(arrBereich)
                    arrDaten(arrBereichIndex) = WS.Range(arrBereich(arrBereichIndex)).Value2
                Next arrBereichIndex
                
                'Zielzeile suchen
                lngZmax = wsAusgabe.Cells(2 ^ 16, 1).End(xlUp).Row + 1
                'Daten ausgeben
                wsAusgabe.Range(wsAusgabe.Cells(lngZmax, 1), wsAusgabe.Cells(lngZmax, UBound(arrDaten) + 1)) = arrDaten
            
            Next lngTab
            'Datei schliessen
            WB.Close False
        End If
        'nächste Datei
        strDatei = Dir()
    Loop


Aufräumen:
    'Notfalls Datei schliessen
    On Error Resume Next
    WB.Close False
    On Error GoTo 0
    
    'Variablen zurücksetzen
    Set WB = Nothing
    Set WS = Nothing
    Set wsAusgabe = Nothing
End Sub