Excel可以一次删除多个列的重复列 [英] Excel to remove duplicates one column at a time for many columns

问题描述

我有一个Excel工作簿，有多张表格（40+），每页（30 +）有很多列。

I have an Excel workbook with many sheets(40+) which have many columns in each(30+).

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

My goal is to remove duplicates in each column but not based on any other columns. I would like to repeat this for all columns in all sheets.

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

I tried to create a macro but upon execution the macro will only select the column that I had selected when I created the macro.

推荐答案

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

This code will remove the duplicates from each column in the workbook - treating each column as a separate entity.

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>

As Joshua has said - RemoveDuplicates won't work in earlier version. Providing you have two spare columns at the end of each sheet, this version will work on Excel 2003. It takes advantage of the Advanced Filter to copy the unique values to the end column, clears the original column and pastes the data back again.

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

这篇关于Excel可以一次删除多个列的重复列的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！