Sub test()
Dim lngZiel As Long, lngLetzte As Long
Dim strFirst As String
Dim c As Range
With Sheets("Tabelle2")
On Error Resume Next
lngLetzte = .Cells(52, 3).End(xlDown).Row
.Cells(52, 3).Resize(lngLetzte, 1).ClearContents
On Error GoTo 0
lngZiel = 52
Set c = Columns(9).Find("ja", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
strFirst = c.Address
Do
.Cells(lngZiel, 3).Value = Cells(c.Row, 4).Value
lngZiel = lngZiel + 1
Set c = Columns(9).FindNext(c)
Loop While Not c Is Nothing And c.Address <> strFirst
End If
End With
End Sub