Inhalte vieler excel dateien auslesen und als Liste wiedergeben

Dim fso As Object
Sub ImportData()
    Dim col As New Collection, file As Variant, wb As Workbook, rngDest As Range, ws As Worksheet, rngSource As Range
    'Ordner der die Dateien enthält  
    Const FOLDER = "C:\Ordner"  
    'Filesystemobject  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    'alle Excel-Dateien rekursiv listen  
    getAllFiles fso.GetFolder(FOLDER), True, Array("xlsx", "xls"), col  
    'Screenupdates und eventuelle Dialoge für Batchbetrieb unterdrücken  
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    With Sheets(1)
        'Für jede Excel-Datei  
        For Each file In col
            'nächste freie Zelle in Spalte A ermitteln  
            Set rngDest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)  
            'mit erstem Sheet des Workbooks arbeiten  
            With GetObject(file).Sheets(1)
                ' Wenn C2 nicht leer ist  
                If .Range("C2").Value <> "" Then  
                    'Daten ermitteln  
                    Set rngSource = .Range("D3:H" & .Cells(Rows.Count, "D").End(xlUp).Row)  
                    'Wenn Daten vorhanden sind  
                    If rngSource.Rows.Count > 1 Then
                        ' exclude die Überschriften  
                        Set rngSource = rngSource.Offset(1)
                        ' Kopiere die Daten ins Ziel  
                        rngSource.Copy
                        rngDest.Offset(0, 1).PasteSpecial xlPasteValuesAndNumberFormats
                        ' Setze Datum vor die Zeilen  
                        rngDest.Resize(rngSource.Rows.Count - 1).Value = .Range("C2").Value  
                    End If
                End If
                'Workbook schließen  
                .Parent.Close False
            End With
        Next
    End With
    'Screenupdates und Dialoge wieder einschalten  
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Sub getAllFiles(ByVal fldr As Object, boolRecursion As Boolean, arrFileExtensions As Variant, ByRef col As Collection)
    For Each file In fldr.Files
        For i = 0 To UBound(arrFileExtensions)
            If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) Then
                col.Add file.Path
                Exit For
            End If
        Next
    Next
    If boolRecursion Then
        For Each subFolder In fldr.SubFolders
            getAllFiles subFolder, True, arrFileExtensions, col
        Next
    End If
End Sub

' .......  
' Kopiere die Daten ins Ziel  
rngSource.Copy
rngDest.Offset(0, 1).PasteSpecial xlPasteValuesAndNumberFormats