Option Explicit
Sub Main()
Dim strSuch1 As String, strSuch2 As String
strSuch1 = Worksheets("Tabelle2").Cells(5, 3).Value
strSuch2 = Worksheets("Tabelle2").Cells(10, 3).Value
Suche_Und_Kopiere (strSuch1)
Suche_Und_Kopiere (strSuch2)
End Sub
Sub Suche_Und_Kopiere(strSuche As String)
Dim rngC As Range, lngZeile As Long, strAdresse As String
Worksheets("Tabelle1").Activate
Application.ScreenUpdating = False
With Worksheets("Tabelle1").Columns("A:D")
Set rngC = .Find(strSuche)
If Not rngC Is Nothing Then
strAdresse = rngC.Address
Do
lngZeile = rngC.Row
Range(Cells(lngZeile, 1), Cells(lngZeile, 4)).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
Worksheets("Tabelle3").Activate
End Sub