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)  'als Start / Zielmarken
          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

  'nach den Vorgaben eine ganze Zeile kopieren
  Set Quellbereich = Quelle.EntireRow   'ein ganzer Bereich
  Set Zielbereich = Cells(Ziel.Row, 1)  'das Ziel ist immer nur die erste Zelle wo(hin)
  
  Quellbereich.Copy Destination:=Zielbereich  'Kopiervorgang
  
  'alternativ nur die Bereiche, das Ziel ist immer nur die erste Zelle wo(hin)
  'Set Quellbereich = range(cells(Quelle.Row,1),cells(quelle.row,126) oder woswasi
  'Set Zielbereich = Cells(Ziel.Row, 1) oder woswasi
  'alternative Schreibweise
  'Set Quellbereich = Range("A" & Quelle.Row & ":DV" & Quelle.Row)
  'Set Zielbereich = Range("A" & Ziel.Row)
  
End Sub