Versuch mal das hier:

Option Explicit

Sub DatenImport()
Application.ScreenUpdating = 0
 
    'dim
        Dim FileList$(), sPath$
        Dim ErrorMessage$
        Dim WB1 As Object, WB2 As Object
        Dim CRange As Range, PRange As Range
        Dim I&, J&, cFV&
        Dim WFN$
        
        Dim filename As Variant
        Dim Anzahlueberschriften&
        Dim aa$, qa$, intzeile&
        Dim HL$() 'alle überschriften
        
        Dim AD As Variant
        Dim FV$(), sTerm$
        Dim FVout$(), E&

    'set
        filename = Application.GetOpenFilename _
        ("Micrsoft Excel-Dateien (*.xl*),*.xl*")
        If filename = False Then Exit Sub
        Anzahlueberschriften = InputBox("anzahl") - 1
        ReDim HL(0, Anzahlueberschriften)
    
    'aktuelles workbook speichern, neues öffnen
        Set WB1 = ActiveWorkbook
        Set WB2 = Workbooks.Open(filename)
        For I = 0 To Anzahlueberschriften
            
            aa = InputBox("Wählen Sie eine Zelle aus")
            HL(0, I) = WB2.Sheets(1).Range(aa).Value
        
        Next
        WB2.Close (False)
           
    'set
        WFN = ThisWorkbook.FullName
        sPath = Environ("UserProfile") & "\Desktop\Ergebnisse"
       
        ErrorMessage$ = fListFiles(FileList, sPath, False, "*", "xl*")
        If ErrorMessage$ <> "" Then
            MsgBox ErrorMessage$
            Exit Sub
        End If
       
    'aktuelles workbook speichern, neues öffnen
        Set WB1 = ActiveWorkbook
        ReDim ADat(UBound(FileList), 1)
        ReDim FV(0)
        For I = LBound(FileList) + 1 To UBound(FileList)
               
            If Not FileList(I) = WFN Then
                Set WB2 = Workbooks.Open(FileList(I))
                With WB2.Sheets(1)
                
                    'sheet durchsuchen
                        AD = .UsedRange.Value
                        For J = 0 To Anzahlueberschriften
                            sTerm = HL(0, J)
                            SheetDurchsuchen FV, AD, sTerm, cFV
                        Next
                                    
                End With
                WB2.Close (False)
            Else: J = J + 1
            End If
           
        Next
    
    'ergebnisse kopieren
        E = UBound(FV)
        ReDim FVout(E, 0)
        For I = 0 To E
            FVout(I, 0) = FV(I)
        Next
        Range(Cells(1, 1), Cells(E + 1, UBound(FVout, 2) + 1)).Value = FVout
    
Application.ScreenUpdating = 1
End Sub

Private Function SheetDurchsuchen(ByRef FV$(), AD As Variant, sTerm$, cFV&) As Boolean
    
    'dim
        Dim R&, C%, S1&, S2&, E1&, E2%
    
    'set
        S1 = LBound(AD)
        S2 = LBound(AD, 2)
        E1 = UBound(AD)
        E2 = UBound(AD, 2)
        
    'search
        For R = S1 To E1
            For C = S2 To E2 - 1
                If AD(R, C) = sTerm Then
                    
                    ReDim Preserve FV(cFV)
                    FV(cFV) = AD(R, C + 1)
                    cFV = cFV + 1
                    
                End If
            Next
        Next
    
    'search succesful?
        If cFV > 0 Then SheetDurchsuchen = True
        
End Function