VBA to remove duplicate rows based on date in other column

[harieta]

Hi all,
I've been going through various threads here trying to adapt the code you create for other users but to no avail.

My table has 11 columns and thousands of rows.
Column B has ID numbers that contains duplicates
I need the code to look at the date (format dd/mm/yyyy) that is in column H and delete the duplicate IDs and keep the row that contains the latest date

I've highlighted what the code should remove

Can you please assist
Thank you

 

[Herakles]

Why would you want row 3 deleted?

 

[harieta]

Why would you want row 3 deleted?

I need 1 unique record for each ID (column B) which in this case is row 6 (most recent date)

 

[Herakles]

Are you able to sort the data by column B ascending and column H ascending?

 

[harieta]

Are you able to sort the data by column B ascending and column H ascending?

Raw data is all over the place, with the same ID showing in various rows.
I can do the code do sort one column, but haven't done one that sorts multiple columns

 

[Herakles]

Is your data actually in an Excel table?

 

[harieta]

Yes

 

[harieta]

Is your data actually in an Excel table?

Is your data actually in an Excel table?

Yes

 

[harieta]

Hi again,
Any help please?

 

[Herakles]

Apologies for the delay. I had to research this and write some code.

Make a backup of your data.
Place this code in a standard code module.
Substutute the word 'Duplicates' on the fourth line for the name of your table.
Make sure that the sheet containing the table is the active sheet.
This code sorts the data by H2 and H8 ascending.

Public Sub subDeleteDuplicates()
Dim objTable As ListObject

    Set objTable = ActiveSheet.ListObjects("Duplicates")
    
    With objTable.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("Duplicates[Header2]"), SortOn:=xlSortOnValues, Order:=xlAscending
            .SortFields.Add Key:=Range("Duplicates[Header8]"), SortOn:=xlSortOnValues, Order:=xlAscending
            .Header = xlYes
            .Apply
        End With
                
    objTable.ListColumns.Add.Name = "Delete"
                               
    Application.AutoCorrect.AutoFillFormulasInLists = True
    objTable.ListColumns("Delete").DataBodyRange.Cells(1).Formula2 = "=IF([@Header2]=B3, ""D"","""")"
    Application.AutoCorrect.AutoFillFormulasInLists = True
        
    objTable.ListColumns("Delete").DataBodyRange.Value = _
        objTable.ListColumns("Delete").DataBodyRange.Value
      
        With objTable.DataBodyRange
            .AutoFilter
            .AutoFilter Field:=.Columns.Count, Criteria1:="D"
            .EntireRow.Delete
            .AutoFilter
        End With
        
        objTable.ListColumns(objTable.DataBodyRange.Columns.Count).Delete

End Sub