VBA Excel 2010 - For Loop Delete Row if Next Record is different from previous record based on column values

Question

I have a list of rows, that have several columns, and what I wish to do is, remove the rows that don't match a criteria based on the value of the previous rows. Basicly i have a column with a bunch of ID's that repeat themselfs, and another column with a date.

I've sorted the records ascending by those two columns

   Public Sub sbOrderRecords()

    Application.Sheets("sheet1").Select

    ActiveSheet.Sort.SortFields.Clear
        ActiveSheet.Sort.SortFields.Add Range("A1"), xlSortOnValues, xlAscending
        ActiveSheet.Sort.SortFields.Add Range("E1"), xlSortOnValues, xlAscending
    With ActiveSheet.Sort
        .SetRange Range("A1").CurrentRegion
        .Header = xlYes
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

So my goal is to delete the records where the ID is equal to the previous record but the date is older, leaving only one record by ID with the Newest date.

Public Sub sbDeleteByIMAndDate()

Dim currentIM As String
Dim MaxDateCurrentIM As Date

Dim dateRange As Range
Dim imRange As Range

With Sheets("sheet1")
        Set imRange = .Range(.Range("A2"), .Range("A2").End(xlDown))
End With

Application.ScreenUpdating = False


For IM = 1 To imRange.Rows.Count

    currentIM = Sheets("Sheet1").Cells(IM, 1).value
    currentDate = Sheets("Sheet1").Cells(IM, 5).value

    For J = Range(Range("E2"), Range("E2").End(xlDown)).Rows.Count + 1 To 2 Step -1
        If currentIM = Sheets("Sheet1").Cells(J, 1).Value And currentDate > (Sheets("Sheet1").Cells(J, 5).Value)  Then
            Rows(J).EntireRow.Delete
        End If
    Next J

Next IM

Application.ScreenUpdating = True

End Sub

This seems to work but it's very slow, and only has around 6000 records.

Any suggestion would by highly appreciated

Answer 1

Okay, give this a try and tweak it accordingly if required.

Sub DuplicateRows()
Dim ws As Worksheet
Dim lr As Long, i As Long
Dim Rng As Range

With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set ws = Sheets("Sheet1")
lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'Assuming Column A is ID column and column E is Date column
ws.Sort.SortFields.Clear
ws.Range("A1").CurrentRegion.Sort key1:=Range("A2"), order1:=xlAscending, key2:=Range("E2"), order2:=xlDescending, Header:=xlYes

For i = lr To 2 Step -1
    'Comparing ID column A
    If ws.Cells(i, 1) = ws.Cells(i - 1, 1) Then
        If Rng Is Nothing Then
            Set Rng = ws.Cells(i, 1)
        Else
            Set Rng = Union(Rng, ws.Cells(i, 1))
        End If
    End If
Next i

If Not Rng Is Nothing Then
    Rng.EntireRow.Delete
End If
With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Answer 2

Fastest would probably be to go record a macro and run remove duplicates. Take that and modify it out to meet your needs.

NOTE: Remove duplicates will keep the entry it finds first and delete the rest faster than anything I have ever written. Good for you you are sorting already.

1) Change the E column sort to xlDecsending so your newest fall above your oldest.

2) Select all the cells and click Remove Duplicates in the Data Tab.

3) Un-select all and select only column A.

I think this should do what you want.

Efficiency: You are hitting the sheet to hard. All those checks directly to cells and modifications to those cells are killing you. Research the variant array.

Dim arr() as variant
arr = sheets("WHATEVER").range("A1:B100").value

That is easy and fast. Now your data is in RAM not excel. A variant array assigned like this will start at row 1, column 1 for the first element. arr(1, 1) is cell A1 and arr(1, 2) is B1.

For IM = 1 To 1000
    currentIM = arr(IM, 1).value
    currentDate = arr(IM,5).value

when you want to delete a row in your comparison you can arr(1,1) = "": arr(1,2) = "" when you are finished you can read the data back into the worksheet.

Range("A1:B100") = arr

You would need to sort after but this would be faster than your code and slower than remove duplicates.