VBA Excel 2010-如果“下一个记录”与上一个记录不同（基于列值），则用于“循环删除行”

Question

我有一个行列表，其中有几列，而我希望做的是，根据前几行的值，删除不符合条件的行。 基本上，我有一列带有一堆ID的ID，这些ID可以重复自己，而另一列带有日期。

我按这两列对记录进行了升序排列

   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

因此，我的目标是删除ID等于先前记录但日期较旧的记录，仅按ID保留一条记录，并保留最新日期。

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

这似乎可行，但速度很慢，只有大约6000条记录。

任何建议将不胜感激

Answer 1

好的，尝试一下，并根据需要进行相应的调整。

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

最快的方法可能是记录宏并运行删除重复项。 采取并修改它以满足您的需求。

注意：删除重复项将保留它首先找到的条目，而删除其余项的速度比我写过的任何东西都要快。 对您有好处，您已经在进行排序。

1）将E列的排序更改为xlDecsending，以使您的最新列高于最旧的列。

2）选择所有单元格，然后在“数据”选项卡中单击“删除重复项”。

3）取消全选，仅选择A列。

我认为这应该做您想要的。

效率：您正在努力工作。 所有这些直接检查细胞并对其进行修饰的方法都在杀死您。 研究变量数组。

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

这既简单又快速。 现在，您的数据在RAM中不是很好。 这样分配的变量数组将从第一个元素的第1行第1列开始。 arr(1, 1)是单元格A1，而arr(1, 2)是B1。

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

当您要在比较中删除一行时，可以通过arr(1,1) = "": arr(1,2) = ""完成后，可以将数据读回到工作表中。

Range("A1:B100") = arr

您需要进行排序，但这将比您的代码快，但比删除重复项慢。