Fals es jemanden interessiert, hab es so gelöst:

Option Explicit

Sub Makro1()

Dim fs, f, f1, fc, s, i
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("G:\030_Team\Support-Team\Students\Sprenger\Versuche\TabellenAuslesenVBA\")
Set fc = f.SubFolders

i = 2
  For Each f1 In fc
    Cells(i, 6) = f1.Name & "\"
    i = i + 1
  Next

'Neues Excel Objekt anlegen
'um die zu betrachtende Exceldatei abzulegen

    Dim objExcel        As New Excel.Application

'Sheet Objekt der jeweiligen Exceldatei anlegen
    Dim objSheet        As Object
    
'Anlegen der Hilfsvariablen
    Dim iRow            As Integer
    Dim strDateipfad    As String
    Dim strPfad         As String
    Dim strDateiname    As String
    Dim iVerzeichnisse  As Integer
    Dim strHauptpfad    As String
'Pfad in welchem sich die Dateien der zu
'kopierenden Zellen sich befinden auswählen
    
    strHauptpfad = "G:\030_Team\Support-Team\Students\Sprenger\Versuche\TabellenAuslesenVBA\"
    
'Schleife welche den Zelleninhalt aller aufgelisteten
'Dateien in mehrere Zellen des Hauptprogramms schreibt
    
    For iRow = 2 To 11

'Überprüfen, ob in Spalte "Dateiname" ein solcher eingetragen ist.
'Fals nicht, wird die Zeile mit einer Fehleranzeige übersprungen.
'(der Arbeitsvorgang wird fortgesetzt)

        If Cells(iRow, 2) = "" Then
        
            Cells(iRow, 3) = "X"
        
        Else
        
        
    For iVerzeichnisse = 2 To 5
        
        strPfad = strHauptpfad & Cells(iVerzeichnisse, 6)
        
        strDateiname = Cells(iRow, 2)
        strDateipfad = strPfad & strDateiname
            
'Überprüfen, ob die in der Tabelle angegebene Datei vorhanden ist.
'fals nicht, wird die Zeile mit einer Fehleranzeige übersprungen.
'(der Arbeitsvorgang wird fotzgesetzt)
            
            If Dir(strDateipfad) = "" Then
                Cells(iRow, 3) = "X"
            Else
                objExcel.Workbooks.Open strDateipfad
                Set objSheet = objExcel.Sheets("Sheet1")
                Cells(iRow, 1) = objSheet.Cells(25, 1)
                Cells(iRow, 3) = "-"
                GoTo DateiGefunden
            End If
        
        
       Next iVerzeichnisse
DateiGefunden:
     End If
    Next iRow

'Objekte (Mappe+Sheet) löschen
'Speicherdialog aufrufen

    objExcel.EnableEvents = False
    objExcel.DisplayAlerts = False

    objExcel.ActiveWorkbook.Close SaveChanges:=False
    objExcel.Quit

    Set objExcel = Nothing
    Set objSheet = Nothing

    Dim strDateinameNeu As String
    strDateinameNeu = "Tabelle mit Inhalt"
    
    Application.Dialogs(xlDialogSaveAs).Show "G:\030_Team\Support-Team\Students\Sprenger\" & strDateinameNeu

End Sub