宏写字典键阵列不工作

Question

我试图用字典来从列范围内创造的独特的项目阵列

列单元格是文本（标题）

我还不是很了解字典，努力学习新的东西

我得到一个数组装满1的

感谢

Sub GetUniques() 
Dim d As Object, k, a As Variant, c As Variant, i As Long, j As Long, LR As Long 

Set d = CreateObject("Scripting.Dictionary") 
LR = Cells(Rows.Count, 1).End(xlUp).Row 
c = Range("D2:D" & LR).Value2 

For i = 1 To UBound(c) 
d(c(i, 1)) = 1 
Next i 

ReDim a(1 To d.Count) 
j = 1 
For Each k In d.keys 
    a(j) = k 
     j = j + 1 
Next k 

'See what the first item of the array is 
MsgBox a(1) 

End Sub 

Answer 1

我使用集合来创建独特的项目。下面是一个例子

Sub Sample() 
    Dim ws As Worksheet 
    Dim lRow As Long, i As Long 
    Dim Col As New Collection, itm As Variant 

    Set ws = ThisWorkbook.Sheets("Sheet1") 

    With ws 
     lRow = .Range("A" & .Rows.Count).End(xlUp).Row 

     For i = 1 To lRow 
      On Error Resume Next 
      Col.Add .Range("A" & i).Value, CStr(.Range("A" & i).Value) 
      On Error GoTo 0 
     Next i 
    End With 

    For Each itm In Col 
     Debug.Print itm 
    Next 
End Sub 

编辑

如果你想要的是收集到数组转换，那么你可以添加该代码注释

Dim MyAr() As Variant 

ReDim MyAr(0 To (Col.Count - 1)) 

For i = 1 To Col.Count 
    MyAr(i - 1) = Col.Item(i) 
Next 

跟进

这是你正在尝试的吗？

Sub Sample() 
    Dim ws As Worksheet 
    Dim lRow As Long, i As Long 
    Dim Col As New Collection, itm As Variant 

    Set ws = ThisWorkbook.Sheets("Sheet1") 

    With ws 
     lRow = .Range("A" & .Rows.Count).End(xlUp).Row 

     For i = 1 To lRow 
      On Error Resume Next 
      Col.Add .Range("A" & i).Value, CStr(.Range("A" & i).Value) 
      On Error GoTo 0 
     Next i 
    End With 

    Dim MyAr() As Variant 

    ReDim MyAr(0 To (Col.Count - 1)) 

    For i = 1 To Col.Count 
     MyAr(i - 1) = Col.Item(i) 
    Next 

    ws.Range("K1").Resize(UBound(MyAr), 1) = Application.Transpose(MyAr) 
End Sub 

注意：我看到您的查询解决，但如果我是你，我会使用内置RemoveDuplicates这是更为快而短于上述

Columns(1).Copy Columns(11) 
Columns(11).RemoveDuplicates Columns:=1, Header:=xlNo