Hallo Rudi!

Da ich nicht genau weiß, wie du deine Daten speicherst würde ich es wie folgt machen.

Ich gehe davon aus, dass in Spalte A der Name steht und in Spalte D Werte (deshalb wird danach sortiert). Zudem sind bestimmt bei jedem Eintrag mindest in A und D Einträge vorhanden. Der folgenen Code beinhaltet die Sortierung und dann die Namenskennzeichung (2 SChleifen: 1. die alten Namensüberschriften löschen, 2. die neuen Namen eintragen.) Die Namenskennzeichnung kann man auch später einfügen. Vorher sollte aber sortiert sein. Die Zeilen wo A gefüllt und D leer sind (die eingefügten Überschriften), werden gelöscht.

Eine Frage noch zur Sortierung. Die Daten sollen doch nach dem Mitarbeiten sortiert sein. Der Name steht in Spalte A. Müsste da nicht das erste Suchargument Spalte A sein (da steht der Name) und dann erst D. Sonst sortiert du D und dann innerhalb der Werte von D nach A. Dann könnten (zumindest wenn in D Zahlen stehen) die Namen auch durcheinander sein. Im Code sind die Argumente daher getauscht.

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
'alte Namenszeilen löschen
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

' neue Namenszeilen eintragen
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 'oder direkt die Farbe angeb
            
        End If
    Next i
End If
Application.ScreenUpdating = True

End Sub

Schau mal ob das so passt. Und nicht verzweifeln, bekommt man alle hin.

Gruß Matthias