|
如何使用宏示例删除 Excel 中列表中的重复项
项目06/20/2023
适用于:
Excel 2010, Microsoft Office Excel 2007, Microsoft Office Excel 2003
更多信息
Microsoft 提供的编程示例仅用于进行说明，而不提供明示或默示担保。 这包括但不限于适销性或对特定用途的适用性的默示担保。 本文假设您熟悉正在演示的编程语言和用于创建和调试过程的工具。 Microsoft 支持工程师可以帮助解释特定过程的功能，但他们不会修改这些示例以提供新增功能或构建步骤以满足你的特定需要。
示例 1：删除单个列表中的重复项
下面的示例宏搜索 A1：A100 范围内的单个列表，并删除列表中的所有重复项。 此宏要求列表范围内没有空单元格。 如果列表中确实包含空单元格，请按升序对数据进行排序，以便空单元格全部位于列表的末尾。
Sub DelDups_OneList()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through.
iListCount = Sheets("Sheet1").Range("A1:A100").Rows.Count
Sheets("Sheet1").Range("A1").Select
' Loop until end of records.
Do Until ActiveCell = ""
' Loop through records.
For iCtr = 1 To iListCount
' Don't compare against yourself.
' To specify a different column, change 1 to the column number.
If ActiveCell.Row Sheets("Sheet1").Cells(iCtr, 1).Row Then
' Do comparison of next record.
If ActiveCell.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).Delete xlShiftUp
' Increment counter to account for deleted row.
iCtr = iCtr + 1
End If
End If
Next iCtr
' Go to next record.
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
示例 2：比较两个列表并删除重复项
下面的示例宏将一个 (主) 列表与另一个列表进行比较，并删除主列表中第二个列表中的重复项。 第一个列表位于 Sheet1 中的 A1：A10 范围内。 第二个列表位于 Sheet2 中的 A1：A100 范围内。 若要使用宏，请选择任一工作表，然后运行宏。
Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet2").Range("A1:A100").Rows.Count
' Loop through the "master" list.
For Each x In Sheets("Sheet1").Range("A1:A10")
' Loop through all records in the second list.
For iCtr = 1 To iListCount
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet2").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet2").Cells(iCtr, 1).Delete xlShiftUp
' Increment counter to account for deleted row.
iCtr = iCtr + 1
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
|