删除重复项，保留最后一个条目——优化

我正在开发一个宏，它将遍历电子表格并根据两列（Q 列和 D 列）中分别提供的两个条件删除重复的条目（行）。

这是我所拥有的。我在一个小数据集上测试了它，它是slow.

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

有什么不同的方法可以解决这个问题来加快速度吗？现在，我基本上会检查每一行，直到到达顶部。实际上，工作表的行数从 30,000 行到最大行数不等。在我看来，应该有一种更快、更干净的方法来实现我想要做的事情，但我似乎想不出一种方法。

此过程删除由 D 列和 Q 列标识的所有重复行。 在重复项中，它将保留最靠近工作表底部的行。 基本上，在右侧创建一个索引列来对底部的所有重复行进行排序和移动，以便可以在一次调用中删除它们。 请注意，它不会更改单元格公式或格式（如果有）。

Sub DeleteDuplicatedRows()
  Dim rgTable As Range, rgIndex As Range, dataColD(), dataColQ()

  Set rgTable = ActiveSheet.UsedRange

  ' load each column representing the identifier in an array
  dataColD = rgTable.Columns("D").value  ' load values from column D
  dataColQ = rgTable.Columns("Q").value  ' load values from column Q

  ' get each unique row number with a dictionary
  Dim dict As New VBA.collection, indexes(), r&, rr
  On Error Resume Next
  For r = UBound(dataColD) To 1 Step -1
    dict.Add r, dataColD(r, 1) & vbNullChar & dataColQ(r, 1)
  Next
  On Error GoTo 0

  ' index all the unique rows in an array
  ReDim indexes(1 To UBound(dataColD), 1 To 1)
  For Each rr In dict: indexes(rr, 1) = rr: Next

  ' insert the indexes in the last column on the right
  Set rgIndex = rgTable.Columns(rgTable.Columns.count + 1)
  rgIndex.value = indexes

  ' sort the rows on the indexes, duplicates will move at the end
  Union(rgTable, rgIndex).Sort key1:=rgIndex, Orientation:=xlTopToBottom, Header:=xlYes

  ' delete the index column on the right and the empty rows at the bottom
  rgIndex.EntireColumn.Delete
  rgTable.Resize(UBound(dataColD) - dict.count + 1).offset(dict.count).EntireRow.Delete

End Sub