如果第一列和第二列中的术语在下面重复但保留一个，则删除整行

Question

I'm currently having an issue which I don't think i can resolve. I have a table in excel with multiple titles such as “Promoter”, “Account”, “#order”, “Date” & “City” with thousands of rows in it. I just want to know if there is a VBA code to delete specific rows with duplicated values if those were to appear in 2 columns (A and B) Such as if the “Account” and the “Promoter” are the same in many other rows, i just want to delete the duplicates and leave one for accounting purposes.

Example:

Data

0987:Raymond:ORD-27:NY

1256:Hannah :ORD-99:MI

1345:André  :ORD-45:WI

1866:Darryl :ORD-02:WA

6419:John.  :ORD-22:CA

0987:Raymond:ORD-87:MN

0987:Raymond:ORD-24:CO

Result:

1256:Hannah :ORD-99:MI

1345:André  :ORD-45:WI

1866:Darryl :ORD-02:WA

6419:John.  :ORD-22:CA

0987:Raymond:ORD-87:MN

Because the “account” (09087) and the “Promoter” (Raymond) are repeated in the rows below even though the order and the state are different, i just want to delete the duplicates that fall in that category (Same account and Promoter) and keep one because the orders belong to the same account. There are several “promoters” to consider, that's why I don't know how to proceed.

Thank you very much for your help i will appreciate every answer.

Answer 1

Keep Unique (Two Columns)

• Adjust the values in the constants section.

The Code

Option Explicit

Sub keepUniqueTwoColumns()
    
    Const wsName As String = "Sheet1"
    Const First As Long = 2
    Const ColLR As String = "A"
    Const Col1 As String = "A"
    Const Col2 As String = "B"
    Const Delimiter As String = "|"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    Dim Last As Long: Last = ws.Cells(ws.Rows.Count, ColLR).End(xlUp).Row
    Dim rg1 As Range: Set rg1 = ws.Cells(First, Col1).Resize(Last - First + 1)
    Dim rg2 As Range: Set rg2 = ws.Cells(First, Col2).Resize(Last - First + 1)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim drg As Range
    Dim cel As Range
    Dim Key As Variant
    Dim i As Long
    
    For Each cel In rg1.Cells
        i = i + 1
        Key = rg1.Cells(i) & Delimiter & rg2.Cells(i)
        If dict.Exists(Key) Then
            If drg Is Nothing Then
                Set drg = rg1.Cells(i)
            Else
                Set drg = Union(drg, rg1.Cells(i))
            End If
        Else
            dict.Add Key, Empty
        End If
    Next cel
    Set dict = Nothing
    
    If drg Is Nothing Then
        MsgBox "Nothing deleted.", vbExclamation, "Fail"
    Else
        Dim dCount As Long: dCount = drg.Cells.Count
        drg.EntireRow.Delete
        MsgBox "Deleted rows: " & dCount, vbInformation, "Success"
    End If
    
End Sub