Doppelte Datensätze finden und farbig markieren (in unsortierer Liste)

Option Explicit

Sub Duplikate_Markieren_Verbessert()
    Dim ws As Worksheet
    Dim startZelle As Range
    Dim datenBereich As Range
    Dim zelle As Range
    Dim vergleichsZelle As Range
    Dim startAdresse As String
    Dim gefundeneDuplikate As Object
    Dim schluessel As String
    
    ' Worksheet festlegen
    Set ws = ActiveSheet
    
    ' Startzelle abfragen
    On Error Resume Next
    startAdresse = InputBox("Bitte geben Sie die Startzelle ein (z.B. A1 oder F6):", _
                           "Startposition für Duplikatsprüfung", "A1")
    
    If startAdresse = "" Then
        MsgBox "Vorgang abgebrochen.", vbInformation
        Exit Sub
    End If
    
    Set startZelle = ws.Range(startAdresse)
    
    If startZelle Is Nothing Then
        MsgBox "Ungültige Zellenadresse!", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    
    ' Datenbereich ermitteln
    Set datenBereich = startZelle.CurrentRegion
    
    If datenBereich.Cells.Count = 1 Then
        MsgBox "Kein zusammenhängender Datenbereich gefunden.", vbInformation
        Exit Sub
    End If
    
    ' Performance-Optimierung
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' Dictionary für schnellere Duplikatserkennung
    Set gefundeneDuplikate = CreateObject("Scripting.Dictionary")
    
    ' Zuerst alle Formatierungen entfernen
    datenBereich.Interior.ColorIndex = xlNone
    
    ' Durch alle Zellen iterieren
    For Each zelle In datenBereich.Cells
        If zelle.Value <> "" Then
            schluessel = CStr(zelle.Value)
            
            If gefundeneDuplikate.Exists(schluessel) Then
                ' Duplikat gefunden - rot markieren
                zelle.Interior.Color = RGB(255, 200, 200) ' Hellrot
                
                ' Auch das Original rot markieren (falls noch nicht geschehen)
                If gefundeneDuplikate(schluessel).Interior.ColorIndex = xlNone Then
                    gefundeneDuplikate(schluessel).Interior.Color = RGB(255, 200, 200)
                End If
            Else
                ' Ersten Eintrag speichern
                gefundeneDuplikate.Add schluessel, zelle
            End If
        End If
    Next zelle
    
    ' Ursprungszustand wiederherstellen
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    ' Ergebnis anzeigen
    Dim anzahlDuplikate As Long
    anzahlDuplikate = 0
    
    For Each zelle In datenBereich.Cells
        If zelle.Interior.Color = RGB(255, 200, 200) Then
            anzahlDuplikate = anzahlDuplikate + 1
        End If
    Next zelle
    
    If anzahlDuplikate > 0 Then
        MsgBox anzahlDuplikate & " Zelle(n) mit doppelten Einträgen wurden markiert.", vbInformation
    Else
        MsgBox "Keine Duplikate gefunden.", vbInformation
    End If
    
    ' Zur Startzelle zurückkehren
    startZelle.Select
    
End Sub