Question

我有一张包含多张（40+）的Excel工作簿，每张（30 +）都有很多列。

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

我尝试创建一个宏但在执行时宏只会选择我在创建宏时选择的列。

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

正如约书亚所说 - RemoveDuplicates在早期版本中不起作用。如果每张表的末尾都有两个备用列，则此版本将在Excel 2003上运行。它利用高级过滤器将唯一值复制到结束列，清除原始列并再次粘贴数据。 / p>

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

以下是一些可以帮助您入门的代码。

我所做的是首先创建了一个包含一些重复项的简单列表。我使用了宏录制器（Developer - ＆gt; Record Macro）。

我选择了列表，然后转到数据 - ＆gt;删除重复项。

我停止录制以查看此代码：

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

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

Excel可以为多列删除一次一列的重复项

2 个答案: