This code will use the collection object to quickly determine if data is a duplicate. It uses the .add
method and will return an error if the data is already in the collection and wont be added. We can also use .count
method to see if that item was added to the collection or not.
In the example I have a spreadsheet with four columns of data. Each of the four criteria have to be met if it is to be considered a duplicate.
It is import that any filters applied are cleared or the duplicates will not be located properly

Sub find_duplicates() Dim isvaluenewcollectionitem As New Collection Dim currentcollectioncount As Long Dim CellVal As Variant Dim icount As Long Dim endrow As Long Dim irow As Long Application.ScreenUpdating = False With ThisWorkbook.Sheets("Summary") .AutoFilter.Sort.SortFields.Clear ' clear the filter On Error Resume Next .ShowAllData 'clear the hidden data from the filter On Error GoTo 0 icount = 0 endrow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row 'make sure all rows and columns are hidden for find will not work properly .Range(.Cells(15, "a"), .Cells(endrow, "a")).Interior.Color = xlNone For irow = 15 To endrow CellVal = Range("a" & irow).Value & Range("b" & irow).Value & Range("c" & irow).Value & Range("d" & irow).Value On Error Resume Next isvaluenewcollectionitem.Add CellVal, Chr(34) & CellVal & Chr(34) On Error GoTo 0 If isvaluenewcollectionitem.count > currentcollectioncount Then currentcollectioncount = isvaluenewcollectionitem.count Else icount = icount + 1 Cells(irow, "a").Interior.Color = 65535 End If Next irow ' 'add this code if you want to delete the duplicate rows ' For irow = endrow To 15 Step -1 ' If Range("A" & irow).Interior.Color = 65535 Then ' Rows(irow).Delete ' End If ' Next irow MsgBox icount & " duplicates found" End With End Sub
One thought on “Find and Delete Rows With Duplicate Data”