Moin!

Also noch ein kleiner Exkurs. Wenn das dein Datensatz ist:

Würde Duplikte löschen  die Werte in der letzten Zeile leeren und die Daten darunter hochziehen. Er würde also das Paar SpalteA und SpalteB je Zeile prüfen.  Egal.

Hier mal ein Code der hoffentlich das gewünschte Ergebnis bringt. Ich bin davon ausgegangen, dass die Daten sortiert sind (also die in Spalte A). WEnn nich vorher noch sortieren (könnte man in den Code einbauen, wenn nicht sortiert werden darf, wird der Code komplizierter). Wenn in A die selbe Zahl kommt und in dem Bereich in B auch der Wert doppelt ist, wird in B der Wert gelöscht. Wie immer erstmal an einem Musterdatensatz probieren und nicht auf die ungesicherten Rohdaten loslassen.

VG

Option Explicit
Sub b_werte_clearen()

Dim ende As Long
Dim daten
Dim zeile As Long
Dim wertA As Variant
Dim wertB As Variant
Dim wechsel As Boolean
Dim zwischenspeicher As String

'Anzahl der Eintragungen
ende = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

'Daten aus Spalte A und B
daten = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ende, 2))

'durch alle Daten in Spalte A
wertA = ""
For zeile = 1 To ende
    'schauen ob es leer ist
    wertA = daten(zeile, 1)
    
    If wertA <> "" Then
        'Daten sind nicht leer, so lange bis ein andere Wert in A kommt
        wechsel = False
        'die schon vorhandenemn Werte
        zwischenspeicher = ""
        While wechsel = False
        
            'prüfen ob der wert in B schonmal da war
            If InStr(1, zwischenspeicher, daten(zeile, 2) & ";", vbTextCompare) > 0 Then
                'der Wert war schonmal da, dann löschen
                daten(zeile, 2) = ""
            Else
                'Wert war noch nicht da
                zwischenspeicher = zwischenspeicher & daten(zeile, 2) & ";"
            End If
            'i nnächster Zeie schauen
            zeile = zeile + 1
            If zeile > ende Then
                wechsel = True
            Else
                If daten(zeile, 1) <> wertA Then wechsel = True
            End If
        Wend
        'wieder eins zurück da bei next der nöchste Wert kommt
        zeile = zeile - 1
    End If
Next zeile

'Daten wieder zurück schreiben
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ende, 2)) = daten

End Sub