Excel以删除重复一列的许多列一次

我有一个Excel工作簿与许多工作表（40+），每个（30+）有许多列。

我的目标是删除每列中的重复，但不是基于任何其他列。 我想重复所有表中的所有列。

我试图创build一个macros，但一旦执行macros将只会select我创buildmacros时select的列。

Answer 1

此代码将从工作簿的每个列中删除重复项 – 将每个列作为单独的实体处理。

 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上运行。它利用高级filter将唯一值复制到结束列，清除原始列并再次粘贴数据。

 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 

Answer 2

这里有一些代码让你开始。

我所做的是首先创build一个简单的列表与一些重复。 我使用macroslogging器（开发人员 – >loggingmacros）。

我select了列表，然后去了数据 – >删除重复。

我停止录制看到这个代码：

 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 

我注意到，如果在工作簿中有一个空的工作表，这会引发运行时错误，所以我添加了一些逻辑来testing一个空的工作表。 该testing包括检查使用的行，使用的列和表格中单元格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 

在Office 2007中添加了.RemoveDuplicates方法，如果您使用的是早期版本，则需要使用其他方法。