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

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

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

到目前为止，我有一个VBmacros只能删除重复，如果名字是重复的。

  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 

如果可以运行这个macros一旦文件打开，请咨询。提前感谢

Answer 1

由于您正在使用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 

这个解决scheme基于公式=ISNUMBER(MATCH(A100 & B100 ,A1:A99 & B1:B99, 0))和数组条目，如果在上面的行中有重复项，则返回TRUE否则返回FALSE 。

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

 Private Sub Workbook_Open() Application.EnableEvents = False Call DeleteDups Application.EnableEvents = True End Sub 

Answer 2

您可以使用字典来存储值。 字典中已经存在的任何值都可以在迭代过程中被删除。

码：

 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 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