Delete lines with older date

I have a spreadsheet with 2 columns : ID and Date .

Example :
ID1 1/01/2010
ID1 1/02/2010
ID1 1/03/2010
ID2 1/01/2011
ID2 1/02/2011

I need to have a list with only one line for each ID, namely the one with the most recent date :
ID1 1/03/2010
ID2 1/02/2011

How can I delete the other records (the Excel file contains + 15.000 records) ?

VDREECK,

Welcome to the Excel Forum.

I assume that your data is in columns A and B, beginning in row 1, and that there are no titles in A1:B1.

I use columns D and E as a work area.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and 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. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. 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.

Option Explicit
Sub DeleteDupsExceptLatestDate()
' stanleydgromjr, 01/13/2011
' http://www.excelforum.com/excel-general/759892-delete-lines-with-older-date.html
Dim LR As Long, a As Long, MD As Long
Application.ScreenUpdating = False
Columns("D:E").ClearContents
Rows(1).EntireRow.Insert
Range("A1:B1") = [{"ID","Date"}]
LR = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & LR).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
  , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
  Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns(5), Unique:=True
LR = Cells(Rows.Count, 5).End(xlUp).Row
For a = 2 To LR Step 1
  MD = Application.Match(Cells(a, 5), Columns(1), 1)
  Cells(MD, 4) = "MD"
Next a
LR = Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Range("D1:D" & LR).SpecialCells(xlBlanks).EntireRow.Delete
On Error GoTo 0
Columns("D:E").ClearContents
Application.ScreenUpdating = True
End Sub

Then run the DeleteDupsExceptLatestDate macro.