VBA To delete Rows where duplicates in two columns

gheyman

Well-known Member
Joined
Nov 14, 2005
Messages
1,744
Office Version
  1. 365
Platform
  1. Windows
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.
 

Some videos you may like

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

gheyman

Well-known Member
Joined
Nov 14, 2005
Messages
1,744
Office Version
  1. 365
Platform
  1. Windows
Code:
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

Well-known Member
Joined
Jul 23, 2007
Messages
4,676
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):

Code:
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

Well-known Member
Joined
Nov 14, 2005
Messages
1,744
Office Version
  1. 365
Platform
  1. Windows
Yes, you are right. Mine did not work out. What you sent worked perfectly. Thank You!
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,676

ADVERTISEMENT

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

gheyman

Well-known Member
Joined
Nov 14, 2005
Messages
1,744
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Jul 23, 2007
Messages
4,676

ADVERTISEMENT

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:

Code:
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

Well-known Member
Joined
Feb 1, 2016
Messages
2,575
Office Version
  1. 365
Platform
  1. Windows
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:

Code:
rngDelRange.Delete xlUp
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,676
Thanks Akuini - so simple (not sure how I missed it actually).

Regards,

Robert
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,575
Office Version
  1. 365
Platform
  1. Windows
You're welcome, Robert.:)
 

Watch MrExcel Video

Forum statistics

Threads
1,109,466
Messages
5,528,972
Members
409,848
Latest member
Blomsten
Top