Sub Suche_Und_Kopiere()
Dim rngC As Range, strAdresse As String, strSuche As String
<span style="font-family: Arial, Verdana, sans-serif;">strSuche = Worksheets("Tabelle2").Cells(5, 3).Value</span>
Application.ScreenUpdating = False
With Worksheets("Tabelle1").Columns("A:D")
Set rngC = .Find(Suchstring)
If Not rngC Is Nothing Then
strAdresse = rngC.Address
Do
rngC.Offset(, -0).Resize(, 8).Copy
With Worksheets("Tabelle3")
.Cells(.Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
Set rngC = .FindNext(rngC)
Loop While Not rngC.Address = strAdresse
End If
End With
Application.CutCopyMode = False
End Sub