Sub Daten_suchen()
Dim pfad As String, datei As String, blatt As String, bereich As Range, cell As Object
Dim str_quelldatei As Workbook
Dim str_quellblatt As Worksheet
Dim lng_zeile As Long
Dim lng_ziel_zeile As Long
Dim suchbegriff As String
Dim suchbegriff1 As String
suchbegriff = ThisWorkbook.Sheets("Auslesen").Cells(5, 4).Value
suchbegriff1 = suchbegriff & " "
pfad = "C:\Users\Max\Desktop\"
datei = "Excel2.xlsx"
blatt = "Tabelle1"
Range("B8:F1000").ClearContents
If suchbegriff = "" Then
answer = MsgBox("Es wurde keine Daten eingegeben." & vbNewLine & "Möchten Sie trotzdem suchen?", vbQuestion + vbYesNo + vbDefaultButton2, "Suche")
If answer = vbNo Then
End
End If
Set bereich = Range("B9:F1000")
For Each cell In bereich
cell = cell.Address(False, False)
ActiveSheet.Cells(cell.Row, cell.Column).Value = GetValue(pfad, datei, blatt, cell)
Next cell
Else
Set str_quelldatei = Workbooks.Open(pfad & datei)
Set str_quellblatt = str_quelldatei.Worksheets(blatt)
lng_zeile = 9
lng_ziel_zeile = 9
With str_quellblatt
Do Until .Cells(lng_zeile, 2) = ""
If .Cells(lng_zeile, 5) = suchbegriff1 Then
.Range(.Cells(lng_zeile, 2), .Cells(lng_zeile, 6)).Copy _
ThisWorkbook.Worksheets("Auslesen").Cells(lng_ziel_zeile, 2)
lng_ziel_zeile = lng_ziel_zeile + 1
End If
lng_zeile = lng_zeile + 1
Loop
End With
str_quelldatei.Close savechanges:=False
End If
End Sub
Private Function GetValue(pfad, datei, blatt, cell)
Dim arg As String
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
If Dir(pfad & datei) = "" Then
GetValue = "Datei nicht gefunden"
Exit Function
End If
arg = "'" & pfad & "[" & datei & "]" & blatt & "'!" & Range(cell).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function