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
|