Here's a good one! Delete duplicates with macro keeping only the newest by date

[rkol297]

I have a spreedsheet with 17,000 rows in it. In column D I have ID numbers and in column B I have the dates. There are multiple entries for each ID in column D which gives multiples dates each entry was given in column B. I need a VBA Macro that will identify duplicate entries in Column D and keep only the most recent entry by date in column B. Any help would be greatly appreciated. I'm banging my head on the desk to get this to work thanks!

 

[mirabeau]

if you'd rather have a modification of Domenic's code to suit your described case then:
it assumed that row 4 has headers, and the data to process is from Row5 onward

Sub testmodified()


    Dim Rng As Range
    Dim LastRow As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    LastRow = Cells(Rows.Count, "B").End(xlUp).Row
    
    Set Rng = Range("B4:G" & LastRow)
    
    With Rng
        .Sort key1:=Range("B4"), order1:=xlAscending, key2:=Range("G4"), order2:=xlDescending, _
            Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom
    End With
    
    For i = LastRow To 5 Step -1
        If WorksheetFunction.CountIf(Range(Cells(5, "B"), Cells(i, "B")), Cells(i, "B")) > 1 Then
            Rows(i).Delete
        End If
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "Completed...", vbInformation

End Sub

 

[JimH]

Mirabeau,

When I'm back at work tomorrow, I'll reply showing the spreadsheet with the original data, one after running your code and one with the intended results.

I'm going to limit headings to Row 1, so the data will begin in Row 2. I believe the following lines in Domenic's code should be changed to:

Set Rng = Range("B2:G" & LastRow)
.Sort key1:=Range("B2"), order1:=xlAscending, key2:=Range("G2"), order2:=xlDescending, _

I'm not sure about this one:

For i = LastRow To 5 Step -1
If WorksheetFunction.CountIf(Range(Cells(5, "B"), Cells(i, "B")), Cells(i, "B")) > 1 Then

 

[mirabeau]

Mirabeau,

When I'm back at work tomorrow, I'll reply showing the spreadsheet with the original data, one after running your code and one with the intended results.

I'm going to limit headings to Row 1, so the data will begin in Row 2. I believe the following lines in Domenic's code should be changed to:

Set Rng = Range("B2:G" & LastRow)
.Sort key1:=Range("B2"), order1:=xlAscending, key2:=Range("G2"), order2:=xlDescending, _

I'm not sure about this one:

For i = LastRow To 5 Step -1
If WorksheetFunction.CountIf(Range(Cells(5, "B"), Cells(i, "B")), Cells(i, "B")) > 1 Then

Your changes look OK.
Your last bit should be

Set For i = LastRow To 2 Step -1
        If WorksheetFunction.CountIf(Range(Cells(2, "B"), Cells(i, "B")), Cells(i, "B")) > 1 Then

 

[JimH]

Can you explain what this line of code is doing?

Set For i = LastRow To 2 Step -1
If WorksheetFunction.CountIf(Range(Cells(2, "B"), Cells(i, "B")), Cells(i, "B")) > 1 Then

 

[K&M]

Hi All,

Thank for the codes you have provided. I am using the code below which i have edited from the code provided on this post earlier. It works fine however, i need to retain the data in column C to relate to the data in cloumns A and B. All help will be highly appreciated.

'Sub Macro1()
Sub test()
Dim Rng As Range
Dim LastRow As Long
Dim i As Long

Application.ScreenUpdating = False

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

Set Rng = Range("B1:A" & LastRow)

With Rng
.Sort key1:=Range("A1"), order1:=xlAscending, key2:=Range("B1"), order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With

For i = LastRow To 2 Step -1
If WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(i, "A")), Cells(i, "A")) > 1 Then
Rows(i).Delete
End If
Next i

Application.ScreenUpdating = True

MsgBox "Your List Is Now Updated", vbInformation


End Sub

 

[Domenic]

Try replacing...

Set Rng = Range("B1:A" & LastRow)

with

Set Rng = Range("A1:C" & LastRow)

 

[K&M]

Try replacing...

Set Rng = Range("B1:A" & LastRow)

with

Set Rng = Range("A1:C" & LastRow)

It Worked Thank you very much!!!

 

[Domenic]

You're very welcome!

 

[Moe Kadhom]

Hi, I have a similar problem but I want to show the last two entries. My data is as follow:
A ( duplicated value), B ( unique value) C ( Unique date).
I need the macro to keep the last two entries based on the date.

can you help?

thanks

 

[Domenic]

Some sample data would have help, but I think the following should do...

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] KeepLastTwoEntries()

    [COLOR=darkblue]Dim[/COLOR] Rng [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] LastRow [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    
    LastRow = Cells(Rows.Count, "C").End(xlUp).Row
    
    [COLOR=darkblue]Set[/COLOR] Rng = Range("A1:C" & LastRow)
    
    [COLOR=darkblue]With[/COLOR] Rng
        .Sort key1:=Range("A1"), order1:=xlAscending, key2:=Range("C1"), order2:=xlDescending, _
            Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTop[COLOR=darkblue]To[/COLOR]Bottom
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]For[/COLOR] i = LastRow To 2 [COLOR=darkblue]Step[/COLOR] -1
        [COLOR=darkblue]If[/COLOR] WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(i, "A")), Cells(i, "A")) > 2 [COLOR=darkblue]Then[/COLOR]
            Rows(i).Delete
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR] i
    
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    
    MsgBox "Completed...", vbInformation
        
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Hope this helps!