VBA Unique values | 易学教程

问题

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. 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.

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

回答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

Update: This is how you could do it with a dictionary. You need to add the reference to the 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

回答2:

Just an alternative, without looping (allthough I do also like 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

You wouldn't even need to populate the second array, but you can do a direct value transfer to that other sheet your talking about. No need to populate any array/collection/dicitonary with Unique values, as long as you store the original ones.

来源：https://stackoverflow.com/questions/59123467/vba-unique-values

标签

excel

vba

unique-values