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

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

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

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内存）运行约30-35秒。

Answer 3

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