Delete duplicate for multiple columns using a macro in an excel report

This code helps me to delete duplicate based on multiple criteria, for instance, if column A, B, C have the same values, delete them. I will show different codes including one deleting from the below and one deleting from the top. For delete duplicate on single column, check my article Delete entire rows that contain duplicate incident ticket numbers using a macro in an excel report.

macro excel macro excel

 

When I use the macro ?

To delete cells or rows containing multiple duplicates.

 

How to create the macro ?

Read How to create, edit, hide and select a macro in an excel report

 

How to create the button to associate it with the macro ?

Read How to create a button and associated it to a macro in an excel report

 

How is/are the macro(s) ?

Copy the code below and paste it into your macro. You will see my comments in green if exist so follow the help to adapt to your need.


Sub test()
' change A1:E10 by your full range, if you don´t put full range i.e. A1:C10, it will delete only columns defined in your array
' change Array(1, 2, 3) by your ID columns to check duplicate, i.e. column A = 1, column B = 2, etc.
' if not including header, replace xlYes by xlNo
Range("A1:E10").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End Sub              
              

The same one as above except for a table:


Sub test()
' change table1 by your table
' change Array(1, 2, 3) by your ID columns to check duplicate, i.e. column A = 1, column B = 2, etc.
' if not including header, replace xlYes by xlNo
ActiveSheet.ListObjects("Table1").DataBodyRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End Sub              
              

NOTE: the 2 solutions above may not work properly with hugh data to delete, if it is the case, I use one of the following solutions. This one deleting the entire row from the below (not working for table):


Sub test()
Dim rng As Range
Dim duprng As Range
' change A1:C10 by your range to check duplicate, header row to be included
Set rng = Range("A1:C10")
rng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set duprng = Nothing
For Each Row In rng.Rows
    If Row.EntireRow.Hidden Then
        If duprng Is Nothing Then
           Set duprng = Row
        Else
           Set duprng = Union(duprng, Row)
        End If
    End If
Next
If Not duprng Is Nothing Then duprng.EntireRow.Delete
ActiveSheet.ShowAllData
End Sub              
              

This one deleting the entire row from the top:


Sub test()
Dim rng As Range
Dim rdel As Range
Dim i As Long
Dim dict
Dim j
' change A1:C10 by your range to check duplicate, header row to be included
Set rng = Range("A1:C10")
Set dict = CreateObject("scripting.dictionary")
For i = rng.Rows.Count To 1 Step -1
    Set rdel = rng.Rows(i)
    j = Join(Application.Transpose(Application.Transpose(rdel.Value)), "~~")
    If dict.exists(j) Then rdel.EntireRow.Delete
    dict(j) = True
Next i
End Sub              
              

Interesting Topics