Question

我有一个删除重复项的宏（基于A列）。它对列P升序进行排序然后删除整个重复的行，因此我可以确保宏只删除最旧的行（列P =日期）：

Sub SortAndRemoveDUBS()

Dim Rng As Range
Dim LastRow As Long
Dim i As Long

Application.ScreenUpdating = False

LastRow = Cells(Rows.Count, "B").End(xlUp).Row

Set Rng = Range("A4:P" & LastRow)

With Rng
    .Sort Key1:=Range("A4"), Order1:=xlAscending, key2:=Range("P4"), order2:=xlDescending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
End With

For i = LastRow To 2 Step -1
    If WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(i, "A")), Cells(i, "A")) > 1 Then
        Rows(i).Delete
    End If
Next i

Application.ScreenUpdating = True

End Sub

但宏观很慢......有没有办法加快速度？我认为这是因为他逐一删除了所有重复内容。

Answer 1

您可以通过收集数组中的所有行号来执行最后的删除操作：

（未经测试）

Dim arr() as variant ,cnt As LOng
cnt=0

For i = LastRow To 2 Step -1
    If WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(i, "A")), Cells(i, "A")) > 1 Then
      Redim Preserve arr(cnt)
      arr(cnt) = i  
      cnt=cnt+1
    End If
Next i

If Len(join(arr))> 0 then ActiveSheet.Range("A" & Join(arr, ",A")).EntireRow.Delete

Answer 2

CountIf很慢，一次删除一行很慢。尝试使用Dictionary（您需要设置对Microsoft Scripting Runtime的引用）。

Sub SortAndRemoveDUBS()

Dim Rng As Range
Dim LastRow As Long
Dim i As Long

Application.ScreenUpdating = False

LastRow = Cells(Rows.Count, "B").End(xlUp).Row

Set Rng = Range("A4:P" & LastRow)

With Rng
    .Sort Key1:=Range("A4"), Order1:=xlAscending, key2:=Range("P4"), order2:=xlDescending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
End With

Dim dict As New Dictionary
Dim r As Range

For i = 2 To LastRow
    If dict.Exists(Cells(i, "A").Value) Then
        If r Is Nothing Then
            Set r = Cells(i, "A")
        Else
            Set r = Union(r, Cells(i, "A"))
        End If
    Else
        dict.Add Cells(i, "A").Value, 1
    End If
Next i

r.EntireRow.Delete
Application.ScreenUpdating = True

End Sub

Answer 3

与@Fabrizio的评论相似，我发现这个评论非常有用。

Sub Delete_row()

Dim a As Variant

    ' selects all data in columns A to P and sorts by data in column P from oldest to newest
    Columns("A:P").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range( _
        "P:P"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A:P")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    a = 2

    While Cells(a, 16) <> vbNullString

'       Marks column Q with a value of 1 for every cell in P
'       that has the same date as the previous cell

        If Cells(a, 16) = Cells(a - 1, 16) Then
            Cells(a, 17) = 1
        End If

        a = a + 1
    Wend

'       Filters column Q for the value of 1

        Columns("A:Q").AutoFilter
        ActiveSheet.Range("$A:Q").AutoFilter Field:=17, Criteria1:="<>"

        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.ClearContents

        ActiveSheet.Range("$A:Q").AutoFilter Field:=17

        Columns("A:P").Select
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range( _
            "P:P"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
            xlSortNormal
            With ActiveWorkbook.Worksheets("Sheet1").Sort
            .SetRange Range("A:P")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        Columns("Q:Q").ClearContents

End Sub

我已经更改了代码以提高宏的速度。使用Excel 2010,32位，第二代i5和8GB RAM在大约30-35秒内运行。

删除重复项（大量数据，非常慢）

3 个答案: