Excel VBA – 删除重复项

我尝试在工作簿中对工作表进行sorting。 macrossorting我的表后，它应该删除所有重复基于列A.

但每次使用macros时，都会出现以下错误：

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 arr() As Variant Dim 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 Application.ScreenUpdating = True End Sub 

这一行被突出显示：

 ActiveSheet.Range("A" & Join(arr, ",A")).EntireRow.Delete 

有人看到问题是什么吗？

Answer 1

使用RemoveDuplicates（）

并且，由于您从列“A”中删除所有重复项，您可以在列“A”或列“P”上sorting：我假设您需要后者

 Sub SortAndRemoveDUBS() With Worksheets("MyDataSheet") '<--| change "MyDataSheet" to your actual worksheet name With Range("A4:P" & .Cells(.Rows.Count, "B").End(xlUp).Row) .RemoveDuplicates Columns:=Array(1) .Sort Key1:=Range("P4"), order1:=xlDescending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom End With End With End Sub 

Answer 2

如果你想删除除第一个以外的所有重复，那么这个代码将在2007+工作：

 Sub SortAndRemoveDUBS() Dim Rng As Range Dim LastRow 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 Rng.RemoveDuplicates Columns:=1, Header:=xlYes Application.ScreenUpdating = True End Sub 

编辑：如果你想删除所有重复的代码将完成这项工作：

 Sub SortAndRemoveDUBS() Dim Rng As Range Dim LastRow As Long Dim i As Long Dim RngToDelete As Range Application.ScreenUpdating = False LastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row Set Rng = ThisWorkbook.Worksheets("Sheet1").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 For i = LastRow To 4 Step -1 If WorksheetFunction.CountIf(.Resize(, 1), .Cells(i - 3, 1)) > 1 Then If RngToDelete Is Nothing Then Set RngToDelete = .Cells(i - 3, 1).EntireRow Else Set RngToDelete = Union(RngToDelete, .Cells(i - 3, 1).EntireRow) End If End If Next i End With If Not RngToDelete Is Nothing Then RngToDelete.Delete End If Application.ScreenUpdating = True End Sub 

Answer 3

尝试使用Application.WorksheetFunction.Match方法

例

 Option Explicit Sub Function_Match() Dim vRow As Variant Dim i As Long, LastRow As Long LastRow = WorksheetFunction.CountA(Columns(1)) For i = LastRow To 2 Step -1 vRow = Application.Match(Cells(i, 1).Value, Range(Cells(1, 1), Cells(i - 1, 1)), 0) If Not IsError(vRow) Then Rows(vRow).Delete End If Next End Sub