Excel VBA-删除重复项

Question

I try to sort a sheet in my workbook. After the macro sorted my table it should remove all duplicates based on the column A.

But every time I use the macro, I get the following error:

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

This line gets highlighted:

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

Does someone see what the probleme is?

Answer 1

If you want to remove all duplicates except the first one then this code will work in 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

Edit: If you want to remove all duplicates this code will do the job:

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 2

Use RemoveDuplicates()

and, since you remove all duplicates from column "A" either you sort on column "A" or on column "P": I assume you need this latter

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 3

Try using Application.WorksheetFunction.Match method

Example

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