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

我有一个macros，删除重复（基于列A）。 它排列列P，然后删除整个行是重复的，所以我可以确保macros只删除最古老的行（列P =date）：

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 

但macros观非常缓慢…有没有办法来加速呢？ 我想这是因为他删除了每个重复的一个。

Answer 1

您可以通过收集数组中的所有行号来完成删除操作，如下所示：

（未testing）

 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很慢，一次删除一行很慢。 尝试使用字典（您将需要设置对Microsoft脚本运行时的引用）。

 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

类似@法布里奇奥的评论，我发现这个工作得很好。

 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 

我已经改变了代码来增加macros的速度。 使用Excel 2010（32位，第二代i5和8GB RAM）运行约30-35秒。