Excel一次删除多列中的重复项

Question

我有一个 Excel 工作簿，其中包含许多工作表(40 多个)，每个工作表中都有许多列(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

正如 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