Option Explicit
Rem *************************************************
Rem Vorgaben anpassen
Private Const Vergleichsadresse As String = "D5:D524"
Private Const Suchadresse As String = "D528:D3664"
Rem *************************************************
Sub Vorschlag()
Dim Vergleichsbereich As Range, Suchbereich As Range
Dim Zelle As Range, Treffer As Range
Dim MerkAdresse As String
Set Vergleichsbereich = Range(Vergleichsadresse)
Set Suchbereich = Range(Suchadresse)
Application.ScreenUpdating = False
For Each Zelle In Vergleichsbereich
With ActiveSheet.Range(Suchadresse)
Set Treffer = .Find(Zelle.Value, LookIn:=xlValues)
If Not Treffer Is Nothing Then
MerkAdresse = Treffer.Address
Do
Call Kopiervorgang(Zelle, Treffer)
Set Treffer = .FindNext(Treffer)
Loop While Not Treffer Is Nothing And Treffer.Address <> MerkAdresse
End If
End With
Next Zelle
Application.ScreenUpdating = True
End Sub
Sub Kopiervorgang(ByVal Quelle As Range, ByVal Ziel As Range)
Rem Quellbereich und Zielbereich festlegen
Dim Quellbereich As Range, Zielbereich As Range
Set Quellbereich = Quelle.EntireRow
Set Zielbereich = Cells(Ziel.Row, 1)
Quellbereich.Copy Destination:=Zielbereich
End Sub