Removing duplicates, keeping last entry -- optimization
<p>I'm working on a macro that will go through a spreadsheet and remove duplicate entries (rows) based on two criteria that are provided separately in two columns (columns Q and D).</p>

<p>Here is what I have. I tested it out on a small dataset and it's <em>slow</em>.</p>

<pre><code>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 &gt; 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
</code></pre>

<p>Is there a different way I can approach this problem to speed things up? As it is right now, I'm basically checking each row until I get to the top. The sheets are actually anywhere from 30,000 rows to the max. Seems to me that there should be a faster, cleaner way of achieving what I'm trying to do but I can't seem to think of one.</p>