使用基于两列的VBA删除重复项 - Excel 2003

Question

我正在使用具有下表的Excel 2003，并且如果它们相同，则希望根据名字和姓氏删除重复的行。

-------------------------------------
| first name | last name | balance  | 
-------------------------------------
| Alex       | Joe       | 200      |
| Alex       | Joe       | 200      |
| Dan        | Jac       | 500      |
-------------------------------------

到目前为止，我有一个VB宏，只有在第一个名称重复时才删除重复项。

    Sub DeleteDups() 

    Dim x               As Long 
    Dim LastRow         As Long 

    LastRow = Range("A65536").End(xlUp).Row 
    For x = LastRow To 1 Step -1 
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then 
            Range("A" & x).EntireRow.Delete 
        End If 
    Next x 

End Sub 

并且如果可以在文件打开后运行此宏，请提供建议。提前谢谢

Answer 1

您可以使用字典来存储值。在迭代期间，也可以删除字典中已存在的任何值。

的代码：

Sub RemoveDuplicates()

    Dim NameDict As Object
    Dim RngFirst As Range, CellFirst As Range
    Dim FName As String, LName As String, FullName As String
    Dim LRow As Long

    Set NameDict = CreateObject("Scripting.Dictionary")
    With Sheet1 'Modify as necessary.
        LRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set RngFirst = .Range("A2:A" & LRow)
    End With

    With NameDict
        For Each CellFirst In RngFirst
            With CellFirst
                FName = .Value
                LName = .Offset(0, 1).Value
                FullName = FName & LName
            End With
            If Not .Exists(FullName) And Len(FullName) > 0 Then
                .Add FullName, Empty
            Else
                CellFirst.EntireRow.Delete
            End If
        Next
    End With

End Sub

<强>截图：

开始之前：

运行后：

您可以在Workbook_Open事件中调用此方法，以便在每次打开工作簿时触发它。

如果有帮助，请告诉我们。

Answer 2

由于您使用的是Excel 2003，.RemoveDuplicates和COUNTIFs不受支持，因此您可以试试这个：

Sub DeleteDups()

    Dim x As Long
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim rngToDel As Range
    'change sheet1 to suit
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With ws
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For x = LastRow To 2 Step -1
            If Evaluate("=ISNUMBER(MATCH('" & .Name & "'!A" & x & " & '" & .Name & "'!B" & x & ",'" & .Name & "'!A1:A" & x - 1 & " & '" & .Name & "'!B1:B" & x - 1 & ",0))") Then
                If rngToDel Is Nothing Then
                    Set rngToDel = .Range("A" & x)
                Else
                    Set rngToDel = Union(rngToDel, .Range("A" & x))
                End If
            End If
        Next x
    End With

    If Not rngToDel Is Nothing Then rngToDel.EntireRow.Delete
End Sub

此解决方案基于带有数组条目的公式=ISNUMBER(MATCH(A100 & B100 ,A1:A99 & B1:B99, 0))，如果上面的行中有重复项，则返回TRUE。

要在打开工作簿后立即运行此宏，请将下一个代码添加到FALSE模块：

ThisWorkbook

Answer 3

它适用于excel 2007.尝试2003年可能会帮助你

Sub DeleteDups() 

Sheets("Sheet1").Range("A2", Sheets("Sheet1").Cells(Sheets("Sheet1").Range("A:A").SpecialCells(xlCellTypeConstants).Count, 3)).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

End Sub