CODEWITHSUNDEEP
vbaexcel
gasser
gasser

Reputation: 279

Deleting Duplicates with VBA Based on Two Columns- Excel 2003

I'm using Excel 2003 having the following table and want to remove the duplicate rows based on first name and last name if they are the same. 

-------------------------------------
| first name | last name | balance  | 
-------------------------------------
| Alex       | Joe       | 200      |
| Alex       | Joe       | 200      |
| Dan        | Jac       | 500      |
-------------------------------------

so far i have a VB macro that only remove duplicates if the first name is duplicate.

    Sub DeleteDups() 

    Dim x               As Long 
    Dim LastRow         As Long 

    LastRow = Range("A65536").End(xlUp).Row 
    For x = LastRow To 1 Step -1 
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then 
            Range("A" & x).EntireRow.Delete 
        End If 
    Next x 

End Sub

and please advice if it is possible to run this macro once the file opened.thanks in advance

Upvotes: 1

Views: 7336

Answers (3)

user3466047
user3466047

Reputation: 9

It works in excel 2007. Try in 2003 may be it'll help you

Sub DeleteDups() 

Sheets("Sheet1").Range("A2", Sheets("Sheet1").Cells(Sheets("Sheet1").Range("A:A").SpecialCells(xlCellTypeConstants).Count, 3)).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

End Sub

Upvotes: 1

Dmitry Pavliv
Dmitry Pavliv

Reputation: 35853

Since you're working with Excel 2003, .RemoveDuplicates and COUNTIFs not supported, so you can try this one:

Sub DeleteDups()

    Dim x As Long
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim rngToDel As Range
    'change sheet1 to suit
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With ws
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For x = LastRow To 2 Step -1
            If Evaluate("=ISNUMBER(MATCH('" & .Name & "'!A" & x & " & '" & .Name & "'!B" & x & ",'" & .Name & "'!A1:A" & x - 1 & " & '" & .Name & "'!B1:B" & x - 1 & ",0))") Then
                If rngToDel Is Nothing Then
                    Set rngToDel = .Range("A" & x)
                Else
                    Set rngToDel = Union(rngToDel, .Range("A" & x))
                End If
            End If
        Next x
    End With

    If Not rngToDel Is Nothing Then rngToDel.EntireRow.Delete
End Sub

this solution based on the formula =ISNUMBER(MATCH(A100 & B100 ,A1:A99 & B1:B99, 0)) with array entry, which returns TRUE if there're duplicates in rows above and FALSE othervise.

To run this macro just after opening workbook, add next code to ThisWorkbook module:

Private Sub Workbook_Open()
    Application.EnableEvents = False

    Call DeleteDups

    Application.EnableEvents = True
End Sub

enter image description here

Upvotes: 2

WGS
WGS

Reputation: 14169

You can use a dictionary to store the values. Any value already existing in the dictionary can be deleted during the iteration as well.

Code:

Sub RemoveDuplicates()

    Dim NameDict As Object
    Dim RngFirst As Range, CellFirst As Range
    Dim FName As String, LName As String, FullName As String
    Dim LRow As Long

    Set NameDict = CreateObject("Scripting.Dictionary")
    With Sheet1 'Modify as necessary.
        LRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set RngFirst = .Range("A2:A" & LRow)
    End With

    With NameDict
        For Each CellFirst In RngFirst
            With CellFirst
                FName = .Value
                LName = .Offset(0, 1).Value
                FullName = FName & LName
            End With
            If Not .Exists(FullName) And Len(FullName) > 0 Then
                .Add FullName, Empty
            Else
                CellFirst.EntireRow.Delete
            End If
        Next
    End With

End Sub

Screenshots:

Before running:

enter image description here

After running:

enter image description here

You can call this from a Workbook_Open event to trigger it every time you open the workbook as well.

Let us know if this helps.

Upvotes: 4

Related Questions