0

我正在尝试在 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
4

2 回答 2

4

你可以像这样修复代码

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（工具/参考）的引用：

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
于 2019-12-01T07:38:43.133 回答
1

只是一个替代方案，没有循环（尽管我也喜欢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

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

于 2019-12-01T08:40:15.370 回答