How to remove duplicates with two columns in VBA

[tonyjyoo]

Hello,

I need 2 things.

1. I need a formula in my excel spreadsheet that picks up duplicates. The range for the duplicates would be within 1 column. Right now I have:

=COUNTIF(A:A,A1)>1

which basically counts if it comes up more than once, then reading either true or false.


[TABLE="width: 500"]
<tbody>[TR]
[TD]Name

[/TD]
[TD]Cost Center[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Tony Yoo[/TD]
[TD]1001[/TD]
[TD]True[/TD]
[/TR]
[TR]
[TD]Tony Yoo[/TD]
[TD]1001[/TD]
[TD]True[/TD]
[/TR]
[TR]
[TD]Bob Marley[/TD]
[TD]9999[/TD]
[TD]False[/TD]
[/TR]
[TR]
[TD]Tony Yoo[/TD]
[TD]5555[/TD]
[TD]True[/TD]
[/TR]
</tbody>[/TABLE]


However, I need something that can recognize if there are duplicates given circumstances with 2 columns (in this case, looking at "Name" and "Cost Center" criteria), giving me something like this after removing the duplicates:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name

[/TD]
[TD]Cost Center[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Tony Yoo[/TD]
[TD]1001[/TD]
[TD]True[/TD]
[/TR]
[TR]
[TD]Bob Marley[/TD]
[TD]9999[/TD]
[TD]False[/TD]
[/TR]
[TR]
[TD]Tony Yoo[/TD]
[TD]5555[/TD]
[TD]True[/TD]
[/TR]
</tbody>[/TABLE]

So it delete the duplicate row with "Tony Yoo" and cost center "1001".

2. To sum it all up, I was thinking of putting this into VBA to automatically look for these duplicates and then remove.

I know this is long but any advice is appreciated!!!

Thank you,

Tony

 

[Muhammad_Usman]

Try this code

Sub Macro()
'
' Delete Duplicate
'


'
Range("A1:B10").Select
ActiveSheet.Range("$A$1:$B$10").RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlNo
ActiveWorkbook.Save
End Sub

 

[Upex]

If you want to keep it formula based / simple, I'd replace your true false column with a new combination field, say =a1&b1 then use the excel built-in dedupe feature as needed on that combined column, thus removing duplicates of 'Tony Yoo1001' any rouge spaces would likely cause issues there though, I.e. 'Tony Yoo1001' and 'Tony Yoo 1001' are not the same (space or not after Yoo). If picked from validation, no issue, if typed freely, more likely to be a trouble with some trimming and other checks etc.

Could also stick conditional formatting on the new combined column to flag when it's found a dupe etc, so easy to see and know when to de-dupe, but allows you to ratify if you want removed, ie in case of a typo, or wanting to keep one entry over the other (if other data associated to each row) etc. Maintains some degree of manual control but makes life a bit easier.

 

[tonyjyoo]

Try this code

Sub Macro()
'
' Delete Duplicate
'


'
Range("A1:B10").Select
ActiveSheet.Range("$A$1:$B$10").RemoveDuplicates Columns:=Array(1, 2), Header _
:=xlNo
ActiveWorkbook.Save
End Sub

The above code doesn't work. Is it because I have headers ("Name", "Cost Center") and that if I increase the range to A1:B1000, it's having a hard time because there are some blank cells?

 

[Muhammad_Usman]

Can you share your sheet ...

 

[Trebor76]

Hi tonyjyoo,

Try this - though initially on a copy of your data as the results cannot be undone if they're not as expected:

Option Explicit
Sub Macro1()

    Dim objMyUniqueData As Object
    Dim lngLastRow      As Long
    Dim lngMyRow        As Long
    Dim rngDelRange     As Range
    
    Application.ScreenUpdating = False

    Set objMyUniqueData = CreateObject("Scripting.Dictionary")
    
    lngLastRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = 2 To lngLastRow 'Starts at Row 2. Change to suit if necessary.
        If Len(Range("A" & lngMyRow)) > 0 And Len(Range("B" & lngMyRow)) > 0 Then
            If objMyUniqueData.Exists(CStr(Range("A" & lngMyRow)) & CStr(Range("B" & lngMyRow))) = False Then
                objMyUniqueData.Add CStr(Range("A" & lngMyRow)) & CStr(Range("B" & lngMyRow)), CStr(Range("A" & lngMyRow)) & CStr(Range("B" & lngMyRow))
            Else
                If rngDelRange Is Nothing Then
                    Set rngDelRange = Cells(lngMyRow, "A")
                Else
                    Set rngDelRange = Union(rngDelRange, Cells(lngMyRow, "A"))
                End If
            End If
        End If
    Next lngMyRow
    
    'If the 'rngDelRange' range has been set, then...
    If Not rngDelRange Is Nothing Then
        '...delete the row(s) from it
        rngDelRange.EntireRow.Delete
    'Else...
    Else
        '...inform the user that no rows were deleted as there was no duplicates in the dataset.
        MsgBox "There were no rows deleted as no there were no duplicates in the dataset.", vbExclamation, "Delete Row Editor"
    End If
    
    Application.ScreenUpdating = True
    
    Set objMyUniqueData = Nothing

End Sub

Regards,

Robert