Removing Duplicate Values - 2 Columns

I have an excel file with 12,000 rows containing serial numbers and dates.

The serial numbers are duplicated throughout the sheet as they have multiple dates. How can I delete duplicate serial number values, but keep the latest date value?

I have attached an example excel file.

Thanks!

Hello hpaum99,

Welcome to the Forum!

Do you have just these 2 columns in original workbook as well?

Howdy neighbor! How's the weather up there in Delano?

Try this:

Option Explicit

Sub RemoveDupes()
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row

Range("A2:B" & LR).Sort Key1:=Range("A3"), Order1:=xlAscending, Key2:=Range("B3"), _
    Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    
Range("C2") = "key"
Range("C3:C" & LR).FormulaR1C1 = "=IF(RC1=R[1]C1, """", 1)"
Range("A2:C" & LR).AutoFilter Field:=3, Criteria1:="1"

Range("A2:C" & LR).SpecialCells(xlCellTypeVisible).Copy Range("A" & LR + 2)
Range("A2:C" & LR).AutoFilter Field:=3
Range("A1:C" & LR).Delete xlShiftUp
Range("C:C").ClearContents

End Sub

Hello hpaum99,

This macro is not effected by the 8192 cell limit imposed by the SpecialCells method. A button has been added to the sheet to run the macro.

Sub DeleteDuplicates()

  Dim Data() As Variant
  Dim I As Long, N As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim SN As Object
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Sheet2")
    
    Set Rng = Wks.Range("A3:B3")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < RngRow, Rng, Wks.Range(Rng, RngEnd))
    
    Rng.Sort _
        Key1:=Rng.Item(1).Offset(-1, 0), Order1:=xlAscending, _
        Key2:=Rng.Item(2).Offset(-1, 0), Order2:=xlDescending, _
        Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom
        
    ReDim Data(1 To Rng.Rows.Count, 1 To 2)
    
    Set SN = CreateObject("Scripting.Dictionary")
    SN.CompareMode = vbTextCompare
    
    Application.ScreenUpdating = False
    CalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    
      For I = 1 To Rng.Rows.Count
        Key = Rng.Item(I, 1)
        If Key <> "" Then
          If Not SN.Exists(Key) Then
             SN.Add Key, Rng.Item(I, 2)
             N = N + 1
             Data(N, 1) = Rng.Item(I, 1)
             Data(N, 2) = Rng.Item(1, 2)
          Else
             Rng.Item(I, 1).Resize(1, 2).Value = ""
          End If
        End If
      Next I
      
    Rng.Value = Data()
    
    Application.Calculation = CalcMode
    Application.ScreenUpdating = False
      
End Sub

Leith, remember that the Special Cells limitation is 8192 areas, not cells. That can make a distinct difference. FYI.

Hello hpaum99,

Adding the Macro
1. Copy the macro above pressing the keys CTRL+C
2. Open your workbook
3. Press the keys ALT+F11 to open the Visual Basic Editor
4. Press the keys ALT+I to activate the Insert menu
5. Press M to insert a Standard Module
6. Paste the code by pressing the keys CTRL+V
7. Make any custom changes to the macro if needed at this time.
8. Save the Macro by pressing the keys CTRL+S
9. Press the keys ALT+Q to exit the Editor, and return to Excel.

To Run the Macro...
To run the macro from Excel, open the workbook, and press ALT+F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Mine updated, not sure if you've tried it or not, you may have missed it above originally:

Option Explicit

Sub RemoveDupes()
Dim LR As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row

Range("A2:Z" & LR).Sort Key1:=Range("A3"), Order1:=xlAscending, Key2:=Range("B3"), _
    Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    
Range("EE2") = "key"
Range("EE3:EE" & LR).FormulaR1C1 = "=IF(RC1=R[1]C1, """", 1)"
Range("A2:Z" & LR).AutoFilter Field:=3, Criteria1:="1"

Range("A2:Z" & LR).SpecialCells(xlCellTypeVisible).Copy Range("A" & LR + 2)
Range("A2:Z" & LR).AutoFilter Field:=3
Range("A1:Z" & LR).Delete xlShiftUp
Range("EE:EE").ClearContents

Application.ScreenUpdating = True
End Sub

Post up your actual workbook (dummy out the data if you need) so we can see why it acts differently in this workbook.

Ah, see...significantly different. Having an Excel "List" already active makes this a much different creature.

This version will remove the list so the macro can edit the data, then reapply the list for you.

Option Explicit

Sub RemoveDupes()
Dim LR As Long
Dim oLo As ListObject, lName As String

For Each oLo In ActiveSheet.ListObjects
    lName = oLo.Name
    Exit For
Next oLo

Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row

'Remove LIST
    If Len(lName) > 0 Then ActiveSheet.ListObjects(lName).Unlist

'Sort Data
    Range("A2:Z" & LR).Sort Key1:=Range("A3"), Order1:=xlAscending, Key2:=Range("B3"), _
        Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    
'Remove duplicates
    Range("EE1") = "key"
    Range("EE2:EE" & LR).FormulaR1C1 = "=IF(RC1=R[1]C1, 1, """")"
    Range("EE:EE").AutoFilter Field:=1, Criteria1:="1"
    
    Range("A2:Z" & LR).SpecialCells(xlCellTypeVisible).Delete xlShiftUp
    ActiveSheet.AutoFilterMode = False
    Range("EE:EE").ClearContents

'Reapply LIST
    LR = Range("A" & Rows.Count).End(xlUp).Row
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("C1:W" & LR), , xlYes).Name = "List1"

Application.ScreenUpdating = True
End Sub

Also, in the future, just start with a sample workbook more indicative of your needs. The initial workbook not only had no active LIST, the data was positioned differently. We could probably get it done in 1-2 posts with an accurate sample workbook.

Glad it worked out!

If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.