Hallo nochmal

den 2. Wunsch auch noch eingebaut. 

Sub Gleiche_weg()
    On Error GoTo Fehler
    Dim TB As Worksheet
    Dim Sp As Integer, LR As Long, LC As Integer
    Const APPNAME = "Gleiche_weg"
    
    '*** bescheunigt das Makro
    Application.ScreenUpdating = False
    
    '*** Stammdaten Anfang
    Set TB = Sheets("Tabelle1")
    Sp = 1 'Spalte A
    '*** Stammdaten Ende
    
    With TB
        'möglichen Autofilter ausschalten
        If .AutoFilterMode Then .AutoFilterMode = False
    
        LR = .Cells(.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte
        LC = .Cells(1, .Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile

        'Temporäre Spalten / Formeln
        .Cells(1, LC + 2) = "Temp"
        .Cells(1, LC + 3) = "Anzahl"
        .Cells(1, LC + 4) = "Wiederholung"
        
        .Cells(2, LC + 2).Resize(LR - 1, 1).FormulaR1C1 = "=RC[-4]&""|""&RC[-3]"
        .Cells(2, LC + 3).Resize(LR - 1, 1).FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
        .Cells(2, LC + 4).Resize(LR - 1, 1).FormulaR1C1 = "=COUNTIF(R2C[-6]:RC[-6],RC[-6])"
        
        'Filtern mehrfach
        .Columns(LC + 3).AutoFilter Field:=1, Criteria1:=">1"
        
        'gefilterte Zeilen löschen
        .Cells(1, 1).CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilterMode = False
        
        'Filtern mehrfach
        .Columns(LC + 4).AutoFilter Field:=1, Criteria1:=">1"
        
        'doppelt KST löschen
        Intersect(.Cells(1, 1).CurrentRegion.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow, .Columns(1)).ClearContents
        .AutoFilterMode = False
        
        'temporäte Spalten weg
        .Columns(LC + 2).Resize(, 3).Delete
        
    End With
    
    
    '*** Fehlerbehandlung
    Err.Clear
Fehler:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear

End Sub

LG UweD