Removing duplicates, keeping last entry — optimization

Question

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

Answer 1

This procedure deletes all the duplicated rows identified by column D and Q. Among duplicates, it will keep the row the closest to the bottom of the sheet. Basically, an indexed column is created on the right to sort and move all the duplicated rows at the bottom so they can be deleted in a single call. Note that it doesn't alter the cells formula or format if there is any.

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