in fortlaufende Spalten eintgagen

Public Sub Punkte_uebernehmen()
Dim WkSh_1  As Worksheet
Dim WkSh_2  As Worksheet
Dim lZeile As Long
Set WkSh_1 = Worksheets("Tabelle2")
Set WkSh_2 = Worksheets("Tabelle1")
For lZeile = 2 To WkSh_1.Range("B65536").End(xlUp).Row
If WkSh_1.Range("B" & lZeile).Value = WkSh_2.Range("B" & lZeile).Value Then
WkSh_1.Range("D" & lZeile).Value = WkSh_2.Range("D" & lZeile).Value
End If
Next lZeile
End Sub

Mit freundlichen Grüßen
Manfred