excel - VBA唯一值(VBA Unique values)

Question

I'm trying to find all unique values in column A copy the unique items to a collection and then paste the unique items to another sheet.

(我试图在A列中找到所有唯一值，然后将唯一项复制到集合中，然后将唯一项粘贴到另一张纸上。)

The range will be dynamic.

(该范围将是动态的。)

So far I've got the code below, it fails to copy the values to a collection and I know the issue is in defining the aFirstArray because the code worked fine in making a collection before I tried to make it dynamic.

(到目前为止，我已经收到下面的代码，它无法将值复制到集合中，并且我知道问题在于定义aFirstArray因为在尝试使其动态化之前，代码可以很好地进行集合的创建。)

What am I doing wrong in this because the items are not going to a collection, but the code just runs to end without looping.

(我在做错什么，因为这些项不会归入一个集合，但是代码只是运行到最后而没有循环。)

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

  ask by Carlsberg789 translate from so

Answer 1

You could fix the code like that

(您可以像这样修复代码)

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

The reason for your code failing is that a key must be a unique string expression, see MSDN

(代码失败的原因是键必须是唯一的字符串表达式，请参见MSDN。)

Update : This is how you could do it with a dictionary.

(更新 ：这是您可以使用字典的方式。)

You need to add the reference to the Microsoft Scripting Runtime (Tools/References):

(您需要将引用添加到Microsoft脚本运行时（工具/参考）：)

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