宏寫字典鍵陣列不工作

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