Sub nameneintragen()
Dim i As Integer
If Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row > 3 Then
For i = 3 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
Worksheets(1).Range(Worksheets(1).Cells(i + 1, 1), Worksheets(1).Cells(i + 1, 3)).MergeCells = True
Worksheets(1).Cells(i + 1, 1) = Cells(i + 2, 1).Value
Worksheets(1).Cells(i + 1, 1).HorizontalAlignment = xlCenter
End If
Next i
End If
End Sub