Sub Suche_Und_Kopiere()
Dim rngC As Range, strAdresse As String
Application.ScreenUpdating = False
With Worksheets("Tabelle1").Columns("A")
Set rngC = .Find("Beispiel1")
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