VBA To delete Rows where duplicates in two columns

[gheyman]

I want to delete duplicate rows where there is duplicates in columns B and C. In this example rows 3 and 8 would get deleted.

A B C
1 zxcz 123 1qwe
2 zxcz 123 2qurs
3 zxcz 123 1qwe
4 zxcz 124 1qwe
5 asdf 321 a5664
6 asdf 221 q4664
7 asdf 321 a4578
8 asdf 221 q4664

You can use:
Dim DupLstRw As Long

'last row of CBOM
DupLstRw = Sheet2.Range("A" & Rows.Count).End(xlUp).Row



Thanks for the help

PS the data is not sorted.

 

[gheyman]

Sub Macro2()
'
' Macro2 Macro
'
Dim DupLstRw As Long

'last row of CBOM
   DupLstRw = Sheet4.Range("A" & Rows.Count).End(xlUp).Row
'
    Sheet4.Range("A5:V" & DupLstRw).RemoveDuplicates Columns:=Array(2, 3), _
        Header:=xlYes
End Sub

 

[Trebor76]

Hi gheyman,

Try this (though initially on a copy of your data as the results cannot be undone if the results are not as expected):

Option Explicit
Sub Macro1()

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

    lngLastRow = Range("B:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")

    For lngMyRow = 1 To lngLastRow
        If Len(Range("B" & lngMyRow)) > 0 And Len(Range("C" & lngMyRow)) > 0 Then
            strMyKey = Range("B" & lngMyRow) & Range("C" & lngMyRow)
            If objMyUniqueData.Exists(CStr(strMyKey)) = False Then
                objMyUniqueData.Add strMyKey, CStr(strMyKey)
            Else
                If rngDelRange Is Nothing Then
                    Set rngDelRange = Rows(lngMyRow)
                Else
                    Set rngDelRange = Union(rngDelRange, Rows(lngMyRow))
                End If
            End If
        End If
    Next lngMyRow
    
    Set objMyUniqueData = Nothing
    
    If Not rngDelRange Is Nothing Then
        rngDelRange.EntireRow.Delete
        MsgBox "Duplicate row data from columns B and C have now been deleted.", vbInformation
    Else
        MsgBox "There were no duplicated records found in columns B and C to be deleted.", vbExclamation
    End If
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[gheyman]

Yes, you are right. Mine did not work out. What you sent worked perfectly. Thank You!

 

[Trebor76]

You're welcome. Thank you for the thanks and the like

 

[gheyman]

What if my data was in a table named tblPBOM. I notices when I changed the data to a table, the code no longer worked. I think in the future I may be using this data in Power Queries therefore its better if the data is a table.

 

[Trebor76]

This has proved more problematic than it seems (for me anyway). Even though I can create the 'rngDelRange' range for the applicable records in the table to be deleted, I couldn't get the code to delete those records in a single statement as I had done when the data was not in a table. I could loop backwards through the table and delete each applicable row as we go but the order of rows being deleted will be in reverse - not sure if this matters?

In any case the following works:

Option Explicit
Sub Macro2()
    
    Dim objMyUniqueData As Object
    Dim strMyKey As String
    Dim strTableName As String
    Dim strDelRange As String
    Dim wsSourceSheet As Worksheet
    Dim rngDelRange As Range
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim objMyRow As ListRow
    Dim objMyTable As ListObject
        
    Application.ScreenUpdating = False
    
    'Sheet name where the table reseides. Change to suit.
    Set wsSourceSheet = ThisWorkbook.Sheets("Sheet1")
    strTableName = "tblPBOM"
    Set objMyTable = wsSourceSheet.ListObjects(strTableName)
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")
    
    For Each objMyRow In objMyTable.ListRows
        'Note the '2' and '3' represent the column (field) number
        If Len(objMyRow.Range(2)) > 0 And Len(objMyRow.Range(3)) > 0 Then
            strMyKey = objMyRow.Range(2) & objMyRow.Range(3)
            If objMyUniqueData.Exists(CStr(strMyKey)) = False Then
                objMyUniqueData.Add strMyKey, CStr(strMyKey)
            Else
                If rngDelRange Is Nothing Then
                    Set rngDelRange = objMyTable.DataBodyRange.Rows(objMyRow.Index)
                Else
                    Set rngDelRange = Union(rngDelRange, objMyTable.DataBodyRange.Rows(objMyRow.Index))
                End If
            End If
        End If
    Next objMyRow
    
    If Not rngDelRange Is Nothing Then
        lngLastRow = wsSourceSheet.Range(strTableName).Row + wsSourceSheet.Range(strTableName).Rows.Count - 1
        strDelRange = rngDelRange.Address
        For lngMyRow = lngLastRow To 2 Step -1
            If InStr(strDelRange, lngMyRow) > 0 Then
                wsSourceSheet.Rows(lngMyRow).EntireRow.Delete
            End If
        Next lngMyRow
        MsgBox "Duplicate row data from fields 2 and 3 have now been deleted.", vbInformation
    Else
        MsgBox "There were no duplicated records found in fields 2 and 3 to be deleted.", vbExclamation
    End If
    
    Set wsSourceSheet = Nothing
    Set objMyTable = Nothing
    Set objMyUniqueData = Nothing
    Set rngDelRange = Nothing
    
    Application.ScreenUpdating = True

End Sub

Maybe someone reading this can tweak the code so the table rows are deleted in a single statement therefore removing the second loop which seems silly to me as we've already created the applicable deletion range.

Regards,

Robert

 

[Akuini]

Maybe someone reading this can tweak the code so the table rows are deleted in a single statement therefore removing the second loop which seems silly to me as we've already created the applicable deletion range.

Regards,

Robert

You may try:

rngDelRange.Delete xlUp

 

[Trebor76]

Thanks Akuini - so simple (not sure how I missed it actually).

Regards,

Robert

 

[Akuini]

You're welcome, Robert.