使用基于两列的 VBA 删除重复项 - Excel 2003
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/22672211/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Deleting Duplicates with VBA Based on Two Columns- Excel 2003
提问by gasser
I'm using Excel 2003 having the following table and want to remove the duplicate rows based on first name and last name if they are the same.
我正在使用具有下表的 Excel 2003，并且希望根据名字和姓氏删除重复的行（如果它们相同）。
-------------------------------------
| first name | last name | balance |
-------------------------------------
| Alex | Joe | 200 |
| Alex | Joe | 200 |
| Dan | Jac | 500 |
-------------------------------------
so far i have a VB macro that only remove duplicates if the first name is duplicate.
到目前为止，我有一个 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
and please advice if it is possible to run this macro once the file opened.thanks in advance
如果文件打开后可以运行此宏，请提供建议。提前致谢
回答by Jerome Montino
You can use a dictionary to store the values. Any value already existing in the dictionary can be deleted during the iteration as well.
您可以使用字典来存储值。字典中已经存在的任何值也可以在迭代过程中删除。
Code:
代码：
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
Screenshots:
截图：
Before running:
运行前：
After running:
运行后：
You can call this from a Workbook_Openevent to trigger it every time you open the workbook as well.
您也可以Workbook_Open在每次打开工作簿时从事件中调用它以触发它。
Let us know if this helps.
如果这有帮助，请告诉我们。
回答by Dmitry Pavliv
Since you're working with Excel 2003, .RemoveDuplicatesand COUNTIFsnot supported, so you can try this one:
由于您使用的是 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
this solution based on the formula =ISNUMBER(MATCH(A100 & B100 ,A1:A99 & B1:B99, 0))with array entry, which returns TRUEif there're duplicates in rows above and FALSEothervise.
此解决方案基于=ISNUMBER(MATCH(A100 & B100 ,A1:A99 & B1:B99, 0))带有数组条目的公式，TRUE如果上面的行和其他行中存在重复项，则返回该公式FALSE。
To run this macro just after opening workbook, add next code to ThisWorkbookmodule:
要在打开工作簿后立即运行此宏，请将下一个代码添加到ThisWorkbook模块：
Private Sub Workbook_Open()
Application.EnableEvents = False
Call DeleteDups
Application.EnableEvents = True
End Sub
回答by user3466047
It works in excel 2007. Try in 2003 may be it'll help you
它适用于 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
