如何遍历每一列并删除Excel（VB）中的重复项

Question

我希望遍历7776列数据并删除重复项。

我无法删除重复项以使用相对单元格引用。

这有效...

ActiveSheet.Range（“ B1：B31”）。RemoveDuplicates列：= 1，标题：= xlNo

但是将其更改为相对，这样我就可以迭代这些列，尽管它们不起作用。

我试图将单元格传递到数组中，然后查找重复项，然后将这些值返回到新的工作表但列位置相同。

任何帮助深表感谢！ 我今天大部分时间都在砖墙上敲打头！

刘易斯

Answer 1

计算您的最大行数和列数，然后遍历各列。

Sub Button1_Click()
    Dim Rws As Long, Col As Long, r As Range
    Set r = Range("A1")
    Rws = Cells.Find(what:="*", after:=r, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Col = Cells.Find(what:="*", after:=r, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    Application.DisplayAlerts = 0
    Application.ScreenUpdating = 0

    For x = 2 To Col
        Range(Cells(1, x), Cells(Rws, x)).RemoveDuplicates Columns:=1, Header:=xlNo
    Next x

End Sub

Answer 2

尝试下面的代码。 它查看有多少列并对其进行迭代。 对于每一列，它查看存在的行数，然后从该列中删除重复项。 开头和结尾处的Application.ScreenUpdating和Application.Calculation位应有助于加快处理速度。

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Dim i As Long
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets("Name of the sheet your data is in")
Dim LastColumn As Long
Dim LastRow As Long

With Ws1
    LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
    For i = 1 To LastColumn
        LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
        Range(.Cells(1, i), .Cells(LastRow, i)).RemoveDuplicates Columns:=1, Header:=xlNo
    Next i
End With

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

Answer 3

当我寻找独立于所用Excel版本的解决方案（RemoveDuplicates需要Excel2013或更高版本）时，建议将范围复制到数组中，将唯一值收集到字典中，然后再单独复制回唯一值：

Option Explicit

Sub UniqueCol()
    ' remove duplicate values from each column
    ' http://stackoverflow.com/questions/34471130/how-to-go-through-each-column-and-remove-duplicates-in-excel-vb
    ' 2015-12-26
    Dim Rng As Range, dst As Range
    Dim MyArray As Variant
    Dim dict As Object
    Dim values As Variant, el As Variant
    Dim col As Long, row As Long, ncols As Long, nrows As Long

    Set Rng = Range("C2:K40")
    nrows = Rng.Rows.Count
    ncols = Rng.Columns.Count

    Set dict = CreateObject("Scripting.Dictionary")

    For col = 1 To ncols
        MyArray = Rng.Columns(col)
        For row = 1 To nrows
            dict(MyArray(row, 1)) = True
        Next row
        values = dict.Keys()
        Rng.Columns(col).Clear
        Set dst = Rng.Columns(col).Cells(1, 1).Resize(UBound(values), 1)
        dst.Value = Application.Transpose(values)
        dict.RemoveAll
    Next col
End Sub

在此，源范围被硬编码为C2：K40。 您将需要对MS Scripting对象的引用。