Sub Joker_übernehmen()
Dim lngZiel As Long, lngLetzte As Long
Dim strFirst As String
Dim c As Range
Dim letzteSpalte As Long
Dim VorletzteSpalte As Long
Dim i As Integer
Application.ScreenUpdating = False
Sheets("Sammler Joker").Activate
With Sheets("Erfassung")
Sheets("Erfassung").Unprotect
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(5).Find("ja", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
strFirst = c.Address
Do
letzteSpalte = Sheets("Erfassung").Cells.SpecialCells(xlCellTypeLastCell).Column
VorletzteSpalte = letzteSpalte - 1
.Cells(lngZiel, 3).Value = Cells(c.Row, 4).Value
.Cells(lngZiel, letzteSpalte).Value = Cells(c.Row, 8).Value
.Cells(lngZiel, VorletzteSpalte).Value = Cells(c.Row, 6).Value
lngZiel = lngZiel + 1
Set c = Columns(5).FindNext(c)
Loop While Not c Is Nothing And c.Address <> strFirst
End If
End With
Sheets("Erfassung").Activate
For i = 300 To 52 Step -1
If Range("C" & i) = "" Then
Rows(i).Delete Shift:=xlUp
End If
Next i
ActiveSheet.Protect
Application.ScreenUpdating = True
MsgBox ("Erledigt.")
End Sub