Sub Zuordnung()
Dim Suche, rngCopyA As Range, i&, cnt&, x&
Anz_Spalten = 3
Suche = Worksheets("Tabelle2").Range("A1:A500")
Set A = Worksheets("Tabelle1")
Set B = Worksheets("Tabelle4")
lrowB = B.Cells(Rows.Count, 1).End(xlUp).row
For i = lbound(Suche) To UBound(Suche)
For cnt = 1 To A.Cells(Rows.Count, 1).End(xlUp).row
If Suche(i,1) = A.Cells(cnt, 1).Value Then
Set rngCopyA = A.Cells(cnt, 2).Resize(1, Anz_Spalten)
For x = 1 To lrowB
If Suche(i,1) = B.Cells(x, 1).Value Then
B.Cells(x, "C").Resize(1, Anz_Spalten).Value = rngCopyA.Value
End If
Next
End If
Next
Next
End Sub