CODEWITHSUNDEEP
exceldictionaryvba
xyz
xyz

Reputation: 2300

Macro to write dictionary keys to array not working

I am trying to use a dictionary to create array of unique items from a column range

The column cells are text (titles)

I know very little about dictionaries, trying to learn something new

I get an array filled with 1's

Thanks

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

Upvotes: 1

Views: 2315

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149297

I use collection to create unique items. Here is an example

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

enter image description here

EDIT

And if you want to convert that collection to array then you can add this code

Dim MyAr() As Variant

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

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

Followup from comments

Is this what you are trying?

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

Note: I see that your query is solved but If I was you, I would use the inbuilt RemoveDuplicates which is much more faster and shorter than the code above

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

Upvotes: 2

Related Questions