Sub Kopie()
Dim SZelle As Range
Dim Suchwert As String
Dim firstAddress As String
Dim arr(1 To 1, 1 To 5)
Dim i As Long
Suchwert = "produkt 1"
Set SZelle = Tabelle1.Range("5:30").Find(Suchwert)
If Not SZelle Is Nothing Then
firstAddress = SZelle.Address
Do
arr(1, 1) = Range("F" & SZelle.Row).Value
arr(1, 2) = Range("J" & SZelle.Row).Value
arr(1, 3) = Range("K" & SZelle.Row).Value
arr(1, 4) = Range("G" & SZelle.Row).Value
arr(1, 5) = Range("I" & SZelle.Row).Value
i = Tabelle2.Cells(Rows.Count, 1).End(xlUp).Row
i = IIf(i = 1, 1, i + 1)
Tabelle2.Cells(i, 1).Resize(1, 5).Value = arr
Set SZelle = Tabelle1.Range("5:30").FindNext(SZelle)
Loop While Not SZelle Is Nothing And SZelle.Address <> firstAddress
End If
End Sub