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

 

[harieta]

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

Thank you, will try it later tonight and keep you posted

 

[harieta]

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

Hi,
I changed the name of table and headers in the code but when I run it it removed all data .

I tried to removed "table" formatting and now just have data with headers,
how would the code change?