Ich arbeite an einem Makro, das eine Tabelle durchläuft und doppelte Einträge (Zeilen) basierend auf zwei Kriterien entfernt, die separat in zwei Spalten (Spalten Q und D) angegeben werden.

Hier ist was ich habe. Ich habe es an einem kleinen Datensatz getestet und es istschleppen.

Sub RemoveDupesKeepLast()
dim i As Integer
dim criteria1, criteria2 As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'start at bottom of sheet, go up
For i = ActiveSheet.UsedRange.Rows.Count to 2 Step -1

    'if there is no entry, go to next row
    If Cells(i, "Q").Value = "" Then
        GoTo gogo:
    End If

    'set criteria that we will filter for
    criteria1 = Cells(i, "D").Value
    criteria2 = Cells(i, "Q").Value

    'filter for criteria2, then criteria1 to get duplicates
    ActiveSheet.Range("A":"CI").AutoFilter field:=17, Criteria1:=criteria2, Operator:=xlFilterValues
    ActiveSheet.Range("A":"CI").AutoFilter field:=4, Criteria1:=criteria1, Operator:=xlFilterValues

    'if there are duplicates, keep deleting rows until only bottom-most entry is left behind
    Do While Range("Q2", Cells(Rows.Count, "Q").End(xlUp)).Cells.SpecialCells(xlCellTypeVisible).Count > 1
        ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1,17).EntireRow.Delete
    Loop

    'reset autofilter
    If ActiveSheet.FilterMode Then
        Cells.AutoFilter
    End If

gogo:
Next i

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Gibt es einen anderen Weg, wie ich dieses Problem angehen kann, um die Dinge zu beschleunigen? Im Moment überprüfe ich im Grunde jede Zeile, bis ich oben angekommen bin. Die Blätter sind eigentlich überall von 30.000 Reihen bis max. Mir scheint, es sollte einen schnelleren und saubereren Weg geben, um das zu erreichen, was ich versuche, aber mir fällt anscheinend keiner ei