我有一个 Excel 工作簿，其中包含许多工作表（40+），每个工作表都有许多列（30+）。
我的目标是删除每列中的重复项，但不基于任何其他列。我想对所有工作表中的所有列重复此操作。
我尝试创建一个宏，但在执行该宏时只会选择我在创建宏时选择的列。
【问题讨论】：
RemoveDuplicates 的答案在 2003 年或更早的版本中都不起作用。您必须对旧工作簿使用高级过滤器。
此代码将从工作簿中的每一列中删除重复项 - 将每一列视为一个单独的实体。
Sub RemoveDups()
Dim wrkSht As Worksheet
Dim lLastCol As Long
Dim lLastRow As Long
Dim i As Long
'Work through each sheet in the workbook.
For Each wrkSht In ThisWorkbook.Worksheets
'Find the last column on the sheet.
lLastCol = LastCell(wrkSht).Column
'Work through each column on the sheet.
For i = 1 To lLastCol
'Find the last row for each column.
lLastRow = LastCell(wrkSht, i).Row
'Remove the duplicates.
With wrkSht
.Range(.Cells(1, i), .Cells(lLastRow, i)).RemoveDuplicates Columns:=1, Header:=xlNo
End With
Next i
Next wrkSht
End Sub
'This function will return a reference to the last cell in either the sheet, or specified column on the sheet.
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
正如 Joshua 所说 - RemoveDuplicates 在早期版本中不起作用。如果您在每张表的末尾有两个备用列，则此版本将在 Excel 2003 上运行。它利用高级过滤器将唯一值复制到末尾列，清除原始列并再次将数据粘贴回来。
Sub RemoveDups()
Dim wrkSht As Worksheet
Dim lLastCol As Long
Dim lLastRow As Long
Dim i As Long
'Work through each sheet in the workbook.
For Each wrkSht In ThisWorkbook.Worksheets
'Find the last column on the sheet.
lLastCol = LastCell(wrkSht).Column
'Work through each column on the sheet.
For i = 1 To lLastCol
'Find the last row for each column.
lLastRow = LastCell(wrkSht, i).Row
'Only continue if there's more than 1 row of data.
If lLastRow > 1 Then
With wrkSht
FilterToUnique .Range(.Cells(1, i), .Cells(lLastRow, i)), .Cells(1, i)
End With
End If
Next i
Next wrkSht
End Sub
'This function will return a reference to the last cell in either the sheet, or specified column on the sheet.
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
Public Sub FilterToUnique(rSourceRange As Range, rSourceTarget As Range)
Dim rLastCell As Range
Dim rNewRange As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Find the last cell and copy the unique values to the last column + 2 '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rLastCell = LastCell(rSourceRange.Parent)
rSourceRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rLastCell.Parent.Cells(rSourceRange.Row, rLastCell.Column + 2), Unique:=True
''''''''''''''''''''''''''''''''''''''''
'Get a reference to the filtered data. '
''''''''''''''''''''''''''''''''''''''''
Set rLastCell = LastCell(rSourceRange.Parent, rLastCell.Column + 2)
With rSourceRange.Parent
Set rNewRange = .Range(.Cells(rSourceRange.Row, rLastCell.Column), rLastCell)
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Clear the column where the data is going to be moved to. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
rSourceRange.ClearContents
''''''''''''''''''''''''''''''''''''''''''''''
'Move the filtered data to its new location. '
''''''''''''''''''''''''''''''''''''''''''''''
rNewRange.Cut Destination:=rSourceTarget
End Sub
【讨论】：
这里有一些代码可以帮助您入门。
我首先创建了一个包含一些重复项的简单列表。我使用了宏记录器（Developer --> Record Macro）。
我选择了列表，然后转到数据 --> 删除重复项。
我停止录制看到这段代码：
Range("A1:A11").Select
ActiveSheet.Range("$A$1:$A$11").RemoveDuplicates Columns:=1, Header:=xlNo
我调整了.RemoveDuplicates 方法来循环遍历工作表：
Sub RemoveDups()
Dim ws As Worksheet
Dim col As Range
For Each ws In ActiveWorkbook.Sheets
For Each col In ws.UsedRange.Columns
ws.Range(col.Address).RemoveDuplicates Columns:=1, Header:=xlNo
Next col
Next ws
End Sub
我确实注意到，如果您的工作簿中有一个空工作表，这会引发运行时错误，因此我添加了一些逻辑来测试一个空工作表。测试包括检查使用的行、使用的列以及工作表上单元格 A1 的值。如果行数和列数都为 1 并且单元格 A1 中没有任何内容，我认为工作表是空的，代码将跳过它。 如果您确定您的工作簿不会有空工作表，则这完全是可选的。为了完整起见，我只是将其包括在内。
Sub RemoveDups()
Dim ws As Worksheet
Dim col As Range
Dim IsSheetEmpty As Boolean
IsSheetEmpty = False
For Each ws In ActiveWorkbook.Sheets
IsSheetEmpty = ws.UsedRange.Rows.Count = 1 _
And ws.UsedRange.Columns.Count = 1 _
And ws.Cells(1, 1).Value = ""
If IsSheetEmpty = False Then
For Each col In ws.UsedRange.Columns
ws.Range(col.Address).RemoveDuplicates Columns:=1, Header:=xlNo
Next col
End If
Next ws
End Sub
.RemoveDuplicates 方法已添加到 Office 2007 中，如果您使用需要不同方法的早期版本。
【讨论】：