VBA 唯一值

Question

我正在尝试在 A 列中查找所有唯一值将唯一项复制到集合，然后将唯一项粘贴到另一个工作表中。 该范围将是动态的。 到目前为止，我已经得到了下面的代码，它无法将值复制到集合中，我知道问题在于定义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

您甚至不需要填充第二个数组，但您可以直接将值转移到您正在谈论的其他工作表。 只要您存储原始值，就无需使用唯一值填充任何数组/集合/字典。