VBA 唯一值

Question

我正在尝试查找 A 列中的所有唯一值，将唯一项复制到一个集合，然后将唯一项粘贴到另一个 sheet。该范围将是动态的。到目前为止，我得到了下面的代码，它无法将值复制到集合中，我知道问题出在定义 aFirstArray 上，因为在我尝试使其动态化之前，代码在创建集合时运行良好。

我在这方面做错了什么，因为这些项目不会进入集合，但代码只是运行到结束而没有循环。

Sub unique()

Dim arr As New Collection, a
Dim aFirstArray() As Variant
Dim i As Long

aFirstArray() = Array(Worksheets("Sheet1").Range("A2", Range("A2").End(xlDown)))

On Error Resume Next
For Each a In aFirstArray
    arr.Add a, a
Next

For i = 1 To arr.Count
    Cells(i, 1) = arr(i)
Next

End Sub

Answer 1

你可以像那样修改代码

Sub unique()
    Dim arr As New Collection, a
    Dim aFirstArray As Variant
    Dim i As Long

    aFirstArray = Worksheets("Sheet1").Range("A2", Range("A2").End(xlDown))

    On Error Resume Next
    For Each a In aFirstArray
        arr.Add a, CStr(a)
    Next
    On Error GoTo 0

    For i = 1 To arr.Count
        Cells(i, 2) = arr(i)
    Next

End Sub

您的代码失败的原因是键必须是唯一的字符串表达式，请参阅 MSDN

更新：这就是你可以用字典做的。您需要添加对 Microsoft Scripting Runtime (Tools/References) 的引用：

Sub uniqueA()
    Dim arr As New Dictionary, a
    Dim aFirstArray As Variant
    Dim i As Long

    aFirstArray = Worksheets("Sheet1").Range("A2", Range("A2").End(xlDown))

    For Each a In aFirstArray
        arr(a) = a
    Next

    Range("B1").Resize(arr.Count) = WorksheetFunction.Transpose(arr.Keys)

End Sub

Answer 2

只是一个替代方案，没有循环（尽管我也喜欢 Dictionary）：

Sub Test()

Dim arr1 As Variant, arr2 As Variant

With Sheet1
    arr1 = .Range("A2", .Range("A2").End(xlDown))
    .Range("A2", .Range("A2").End(xlDown)).RemoveDuplicates Columns:=Array(1)
    arr2 = .Range("A2", .Range("A2").End(xlDown)).Value
    .Range("A2").Resize(UBound(arr1)).Value = arr1
End With

End Sub

您甚至不需要填充第二个数组，但您可以将值直接转移到您正在谈论的另一个 sheet。无需使用唯一值填充任何 array/collection/dicitonary，只要您存储原始值即可。

VBA 唯一值

VBA Unique values

excel

vba

unique-values