Clear duplicates VBA

[All2Cheesy]

Hi all,

I'm looking to write up a vba code which selects a range containing columns and clears any duplicates found over both columns.

e.g. if cells A2 and B2 contain the same figures as A1 and B1, clear A2 and B2

Could somebody please provide assistance? Thank you.

 

[My Aswer Is This]

You want those ranges cleared or can we just delete the row.

 

[My Aswer Is This]

This script will delete the rows if it find duplicates:

Sub Delete_Duplicates()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = Lastrow To 1 Step -1
        If Cells(i, 1).Value And Cells(i, 2).Value = Cells(i + 1, 1).Value And Cells(i + 1, 2).Value Then
            Rows(i + 1).Delete
        End If
    Next
Application.ScreenUpdating = True
End Sub

 

[All2Cheesy]

This script will delete the rows if it find duplicates:

Sub Delete_Duplicates()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = Lastrow To 1 Step -1
        If Cells(i, 1).Value And Cells(i, 2).Value = Cells(i + 1, 1).Value And Cells(i + 1, 2).Value Then
            Rows(i + 1).Delete
        End If
    Next
Application.ScreenUpdating = True
End Sub

Thanks for that. I will need to clear the cells rather than delete the rows, but I'll have a play around with your code and see what I can do.

 

[My Aswer Is This]

Try this:

Sub Clear_Duplicates()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To Lastrow
        If Cells(i, 1).Value And Cells(i, 2).Value = Cells(i + 1, 1).Value And Cells(i + 1, 2).Value Then
            Range("A" & i + 1 & ":" & "B" & i + 1).ClearContents
        End If
    Next
Application.ScreenUpdating = True
End Sub

 

[All2Cheesy]

I gave that a go earlier, but didn't have much luck. It just seemed to remove the data in the second column.

After trying on a new sheet, I got a Type mismatch (Error 13) error.

 

[Trebor76]

Hi All2Cheesy,

Try this while on the sheet in question:

Option Explicit
Sub Macro1()

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

    lngLastRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")
    
    For lngMyRow = 1 To lngLastRow 'Assumes the data starts at row 1. Change to suit if necessary.
        If objMyUniqueData.Exists(CStr(Cells(lngMyRow, 1) & Cells(lngMyRow, 2))) = False Then
            objMyUniqueData.Add CStr(Cells(lngMyRow, 1) & Cells(lngMyRow, 2)), Cells(lngMyRow, 1) & Cells(lngMyRow, 2)
        Else
            Range(Cells(lngMyRow, 1), Cells(lngMyRow, 2)).ClearContents
        End If
    Next lngMyRow
    
    Set objMyUniqueData = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Any duplicates in Col's A & B have now been cleared.", vbInformation
    
End Sub

Just bear in mind that you should initially try it on a copy of your data as the results cannot be undone if they're not as expected.

Regards,

Robert

 

[All2Cheesy]

Looks like that's done the trick. Thank you!

Hi All2Cheesy,

Try this while on the sheet in question:

Option Explicit
Sub Macro1()

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

    lngLastRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")
    
    For lngMyRow = 1 To lngLastRow 'Assumes the data starts at row 1. Change to suit if necessary.
        If objMyUniqueData.Exists(CStr(Cells(lngMyRow, 1) & Cells(lngMyRow, 2))) = False Then
            objMyUniqueData.Add CStr(Cells(lngMyRow, 1) & Cells(lngMyRow, 2)), Cells(lngMyRow, 1) & Cells(lngMyRow, 2)
        Else
            Range(Cells(lngMyRow, 1), Cells(lngMyRow, 2)).ClearContents
        End If
    Next lngMyRow
    
    Set objMyUniqueData = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Any duplicates in Col's A & B have now been cleared.", vbInformation
    
End Sub

Just bear in mind that you should initially try it on a copy of your data as the results cannot be undone if they're not as expected.

Regards,

Robert

 

[My Aswer Is This]

I test all my scripts so I'm not sure why you had problems.

I gave that a go earlier, but didn't have much luck. It just seemed to remove the data in the second column.

After trying on a new sheet, I got a Type mismatch (Error 13) error.

 

[Trebor76]

Looks like that's done the trick. Thank you!

Thanks for letting us know and you're welcome