Hyperlinks nach Vergleich kopieren...

Private Sub Suchenundfinden_Click()
On Error Resume Next
Dim WS1     As Worksheet
Dim WS2     As Worksheet
Dim WS3     As Worksheet
Dim Suche   As String
Dim find    As Variant
Dim I       As Integer
Set WS1 = Worksheets("Tabelle1")
Set WS2 = Worksheets("Tabelle2")
Set WS3 = Worksheets("Tabelle3")
For I = 1 To 500   'Anzahl der Zeilen
Suche = WS2.Cells(I, 1) 'Suchbegriff aus Tabelle 2 / Spalte A
Set find = WS1.Range("A:A").find(Suche, LookIn:=xlValues) ' In Tabelle 1 / Spalte a suchen
WS2.Rows(find.Row).Format = WS1.Rows(I).Format ' wenn gefunden komplette Zeile von Tabelle 1 nach Tabelle 2 kopieren
Next I
End Sub