Hallo,

naja, die miserable Performance kommt von dir ;-).

Jeder Zugriff auf das Tabellenblatt benötigt sehr viel Zeit, also jedes Cells() noch mehr jedes Rows().delete. Das sind wahnsinnige Zeitfresser.

Drüber hinaus hat dein Code in meinen Augen zwei Logikfehler:

1. du veränderst nicht die Variable i, oder ist das Absicht? Dadurch landest du in einer Endlosschleife und vergleichst immer wieder alle Zeilen mit der ersten??

2. wenn du Zeile 3 löscht, dann wird Zeile 4 zur neuen Zeile 3. Das berücksichtigt dein Code nicht.

Ich habe versucht, deine Vorgehensweise in großen Teilen zu erhalten, gehe aber dennoch ganz anders vor:

Zunächst: ich gehe davon aus, dass dein "Usedrange" Zeile 1 und Spalte A beinhaltet!!

Ich lese das gesamte Tabellenblatt in ein Array (Ar) ein. Die Auslagerung des Vergleiches in die Funktion "Kontrolle"  musste ich wieder eingliedern, denn dann kann man sich das häufige füllen der Variablen txA ersparen.

Ein zweites Array (arDel) benutze ich, um mir zu merken, welche Zeilen gelöscht werden sollen (eine 0 bedeutet löschen).

Habe ich alle Zeilen verglichen, trage ich dieses Array "arDel" ins Tabellenblatt in die erste freie Spalte ein und sortiere das gesamte Tabellenblatt nach ihr. Dadurch sind alle zu löschenden Zeilen oben und die Reihenfolge der anderen Zeilen hat sich nicht verändert. Dann kann ich alle Zeilen auf einmal löschen (das spart immens viel Zeit!).

Hier der Code :

Sub DoppelteEinträgeLöschen()
' ###Variablen###
Dim txA As String, txB As String
Dim lRowMaxI As Long, i As Long, j As Long
Dim Ar As Variant, arDel() As Variant
Dim rngLast As Range, lColMax As Long
 
' ###Sachen abschalten die es nicht braucht###
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


With Sheets(1)

    'Alle Daten in ein Array
    Ar = Range(.Cells(1, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).Value
    ReDim arDel(1 To UBound(Ar), 1 To 1)
    For j = 1 To UBound(Ar)
        arDel(j, 1) = j
    Next
    lRowMaxI = UBound(Ar)
    lColMax = UBound(Ar, 2)
    
    i = 2
    
    Do
        txA = Ar(i, 1) & Ar(i, 2) & Ar(i, 3) & Ar(i, 4) & Ar(i, 5) & Ar(i, 6) & Ar(i, 7) & Ar(i, 8)
        j = i
        Do
            j = j + 1
            txB = Ar(j, 1) & Ar(j, 2) & Ar(j, 3) & Ar(j, 4) & Ar(j, 5) & Ar(j, 6) & Ar(j, 7) & Ar(j, 8)
            
            If txA = txB Then
                arDel(j, 1) = 0         'zum Löschen merken
            End If
    
        Loop Until j = lRowMaxI
        
        i = i + 1
        
    Loop Until i = lRowMaxI - 1
    
    'Ergebnis in das Tabellenblatt in eine Hilfsspalte eintragen
    .Cells(1, lColMax + 1).Resize(UBound(Ar), 1) = arDel
    
    'sortieren
    sortiereBlatt lColMax + 1, .Range("A1").Parent, xlNo
    
    'alle Zeilen, in denen die 0 steht in einem Rutsch löschen
    With .Columns(lColMax + 1)
        'Letzte Zeile mit der 0 finden
        Set rngLast = .Find(0, .Cells(1, 1), LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious)

        'löschen, falls es was zu löschen gibt
        If Not rngLast Is Nothing Then
            .Range(.Cells(1, rngLast.Row), rngLast).EntireRow.Delete
        End If
        
        'Hilfsspalte löschen
        .Delete
    End With

End With

' Sachen wieder einschalten - Performance
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub sortiereBlatt(lCol As Long, Ws As Worksheet, Optional hasHeader As XlYesNoGuess = xlYes)
    Dim rngAll As Range
    With Ws
        Set rngAll = .Range(.Cells(1, 1), .UsedRange.SpecialCells(xlCellTypeLastCell))
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Columns(lCol), _
                             SortOn:=xlSortOnValues, _
                             Order:=xlAscending, _
                             DataOption:=xlSortNormal
        With .Sort
            .SetRange rngAll
            .Header = hasHeader
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

Bitte an Testdaten testen.

ich empfehle dir, hier einen Haltepunkt (Im VBE F9 drücken) zu setzen:

    'Ergebnis in das Tabellenblatt in eine Hilfsspalte eintragen
    .Cells(1, lColMax + 1).Resize(UBound(Ar), 1) = arDel

Und dann im Einzelschritt mit F8 die nächsten Befehle auszuführen. Dabei in der anderen Bildschirmhälfte schauen, was im Tabellenblatt passiert. Dann verstehst du vielleicht besser, was der code macht.

Was sagst du dazu?

Wie ist die Laufzeit, bei wie vielen Datensätzen?

Grüße, Ulrich