Sub nameneintragen()
Dim i As Integer
Application.ScreenUpdating = False
Range("A:AV").Sort _
Key1:=Range("A1"), _
Order1:=xlAscending, _
Key2:=Range("D1"), _
Order2:=xlAscending, _
Header:=xlYes
If Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row > 2 Then
For i = 1 To Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets(1).Cells(i + 1, 1) <> "" And Worksheets(1).Cells(i + 1, 4) = "" Then
Worksheets(1).Rows(i + 1).Select
Selection.Delete
i = i - 1
End If
Next i
End If
If Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row > 2 Then
For i = 1 To Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
Worksheets(1).Rows(i + 1).Select
Selection.Insert Shift:=xlDown
ergeCells = True
Worksheets(1).Cells(i + 1, 1) = Cells(i + 2, 1).Value
Worksheets(1).Range(Worksheets(1).Cells(i + 1, 1), Worksheets(1).Cells(i + 1, 4)).Interior.ColorIndex = 3
End If
Next i
End If
Application.ScreenUpdating = True
End Sub