Excel Dateien durchsuchen und mehrere Werte in neue Excel Datei auslesen

Dim fso As Object
Sub ImportData()
    Dim col As New Collection, file As Variant, wb As Workbook, rngDest as Range, strSearch as String
    'Ordner der die Dateien enthält  
    Const FOLDER = "C:\MeineDateien"  
    strSearch = InputBox("Suchbegriff eingeben")  
    '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)
        'nächste freie Zelle in Spalte A ermitteln  
        Set rngDest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)  
        'Für jede Excel-Datei  
        For Each file In col
            'Workbook öffnen  
            Set wb = Workbooks.Open(file)
            'Suche im Sheet starten  
            Set f = wb.Sheets(1).Range("H10,H11,AP11,P24,L25,L26,BA25,BA26,CJ25,CJ26,CK25,CK26,CA10").Find(strSearch,SearchIn:=xlValues)  
            'Wenn der Wert gedunden wurde  
            if not f is Nothing then
                'schreibe den gefundenen Wert und den Dateinamen in das Zielsheet inkl. Hyperlink  
                rngDest.Resize(1,2).Value = Array(f.Value,file)
                wb.Sheets(1).Hyperlinks.Add rngDest.Offset(0,1),rngDest.Offset(0,1).Value
                'nächste freie Zelle setzen  
                Set rngDest = rngDest.Offset(1, 0)
            End if 
            'WB schließen  
            wb.Close False
        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