Nach Prüfung Farblich unterlegen und Summieren

Sub Doppelte()
    Cells.Select
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16751204
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 10284031
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("C14").Select  
End Sub

Sub MarkDoublesAndSum()
    Dim cell As Range, ref As Range, colorCurrent As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")  
    If MsgBox("Bitte eine Zelle in der Spalte ""Name"" markieren!" & vbNewLine & "Ist das aktuell der Fall?", vbYesNo Or vbInformation) = vbNo Then Exit Sub  
    
    With ActiveSheet
        'ref wird immer die Zelle des ersten Eintrags von doppelten Werten zugewiesen  
        Set ref = .Cells(1, Selection.Column)
        ' Farben setzen  
        colorsHighlight = Array(vbYellow, vbGreen)
        colorCurrent = colorsHighlight(0)
        
        'Ermittle den belegten Bereich der aktuell markierten Spalte  
        With .Range(.Cells(2, Selection.Column), .Cells(.Cells(Rows.Count, "F").End(xlUp).Row, Selection.Column))  
            'Für jede Zelle in Spalte F  
            For Each cell In .Cells
                'Wenn aktuelle Zelle unterschiedlich zur Referenzzelle  
                If cell.Value <> ref.Value And cell.Offset(0, -1).Value <> ref.Offset(0, -1).Value Then
                    Set ref = cell
                    'setze Summe auf 0  
                    ref.Offset(0, -2).Value = 0
                    'Summe initial mit Wert rechts neben Name  
                    ref.Offset(0, -2).Value = cell.Offset(0, 1).Value
                    'Dictionary auf doppelte Personalnummern prüfen  
                    If dic.Exists(cell.Offset(0, -1).Value) Then
                        If dic.Item(cell.Offset(0, -1).Value) <> cell.Value Then
                            cell.Offset(0, -1).Resize(1, 2).Interior.Color = IIf(colorCurrent = colorsHighlight(0), colorsHighlight(1), colorsHighlight(0))
                            cell.Offset(0, -1).Font.Color = vbRed
                            colorCurrent = IIf(colorCurrent = colorsHighlight(0), colorsHighlight(1), colorsHighlight(0))
                        End If
                    Else
                        ' Personalnummer und Name zu Dictionary hinzufügen  
                        dic.Add cell.Offset(0, -1).Value, cell.Value
                    End If
                ElseIf cell.Value = ref.Value And cell.Offset(0, -1).Value <> ref.Offset(0, -1).Value Then
                    'setze Summe auf 0  
                    cell.Offset(0, -2).Value = 0
                    'Markiere Block mit Farbe  
                    ref.Offset(0, -1).Resize(cell.Row - ref.Row + 1, 2).Interior.Color = IIf(colorCurrent = colorsHighlight(0), colorsHighlight(1), colorsHighlight(0))
                    colorCurrent = IIf(colorCurrent = colorsHighlight(0), colorsHighlight(1), colorsHighlight(0))
                    'Summiere Werte und schreibe die Summe  
                    ref.Offset(0, -2).Value = ref.Offset(0, -2).Value + cell.Offset(0, 1).Value
                Else
                    'Doppelter Wert  
                    If IsNumeric(cell.Offset(0, -2)) Then cell.Offset(0, -2).Value = 0
                    'Summiere Werte und schreibe die Summe  
                    ref.Offset(0, -2).Value = ref.Offset(0, -2).Value + cell.Offset(0, 1).Value
                End If
                
            Next
        End With
    End With
End Sub