vba - Excel to remove duplicates one column at a time for many columns

Question

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.

Answer 1

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

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