|
versuchs mal damit. ohne Garantie. Es werden nur die Zellwerte übernommen. Keine Formatierungen
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" 'Suchbegriff
Set SZelle = Tabelle1.Range("5:30").Find(Suchwert)
If Not SZelle Is Nothing Then
firstAddress = SZelle.Address
Do
'F, J, K, G ,I
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
|