vba - Extract Unique values from Single Column via Colllection and Dictionary

Code:

---

Hi Team,


Need vba collection and dictionary help for extracting unique values of Single Column and pasting in Range(d2") via Dictionary
and Range("h2") via Collection


Unique values should be excluding blank. Below is my attempted Code not working.


Sub Unique_List_via_Collection()   


    Dim lr As Long
    Dim i As Long   
    Dim Coll As New Collection   
    lr = Range("a65000").End(xlUp).Row   


    For i = 2 To lr
        If Range("a" & i).Value <> "" Then
            On Error Resume Next
            Coll.Add Range("A" & i).Value, Range("A" & i).Value
            On Error GoTo 0
        End If
    Next i


        getting error at below line.
    Range("d2").Resize(Coll.Count).Value = Application.WorksheetFunction.Transpose(Coll.Items) 

     
End Sub

Thanks in advance for help.     

Regards,
mg

---

mg not sure why U want to use collections and dictionary??? I haven't looked at your file but I assume that it has some dictionary code that also doesn't work? Your code might even work with the correct syntax? There are a number of ways to get and transfer unique data. Here's a simple array method to load an array with unique values which then can be unloaded wherever. HTH. Dave

Code:

---

Function UniqueArr(InArr As Variant) As Variant
'returns array of unique values from inputted array
Dim Cnt As Integer, Cnt2 As Integer, Cnt3 As Integer, TempArr() As Variant
For Cnt = UBound(InArr) - 1 To LBound(InArr) Step -1
For Cnt2 = Cnt - 1 To 0 Step -1
If InArr(Cnt) = InArr(Cnt2) Then
GoTo below
End If
Next Cnt2
ReDim Preserve TempArr(Cnt3)
TempArr(Cnt3) = InArr(Cnt)
Cnt3 = Cnt3 + 1
below:
Next Cnt
UniqueArr = TempArr
End Function

---

To operate would be something like...

Code:

---

Dim ArrTemp() as Variant, Arr() as Variant, Lr s double
lr = Sheets("Sheet1"). Range("a65000").End(xlUp).Row   
Set ArrTemp = Sheets("Sheet1").Range("a1:a" & lr)
Set Arr =  UniqueArr(ArrTemp)

---

The array Arr should then contain an array of unique values :)

Hi Dave,

Thanks for help , I tried your code, but getting error.
I got one help from Google, below code works but it also add blank as key, how to skip blank in dictionary. Thanks.

Public Sub DictionaryExamples()
Dim aKey As String
Dim i As Long
Dim dict As Object
Dim arr As Variant
Set dict = CreateObject("Scripting.Dictionary")
Dim lr As Long



lr = Range("a1000").End(xlUp).Row
arr = Range("a2:a" & lr).Value


'Instantiate a dictionary
Set dict = CreateObject("scripting.dictionary")

For i = 1 To UBound(arr)
On Error Resume Next
If Range("a" & i).Value = "" Then
Else
aKey = CStr(arr(i, 1))
dict.Add aKey, 1
End If
Next i

Range("E1").Resize(dict.Count).Value = Application.Transpose(dict.Keys)
Range("F1").Resize(dict.Count).Value = Application.Index(dict.Items, 0)
End Sub


Regards,
mg

@mg What error do you get? Works perfectly well for me.

I made an interesting thing. The results are sorted.
But I did AutoFilter in advance.
The code like below:

Code:

---

Sub Unique_List_via_AutoFilter()
    Dim arr
    arr = Application.Substitute(ActiveSheet.AutoFilter.Filters.Item(1).Criteria1, "=", "")
    [f2].Resize(UBound(arr)) = Application.Transpose(arr)
End Sub

---

That's neat Wolfie :thumb

@paulked
:beerchug:

Code:

---

Sub M_snb()
    Sheet1.Columns(1).AdvancedFilter 2, , Sheet1.Cells(1, 6), 1
    Sheet1.Columns(6).SpecialCells(4).Delete
End Sub

---

If you are interested in Dictionaries: http://www.snb-vba.eu/VBA_Dictionary_en.html

As I mentioned, many ways to achieve uniqueness. My bad code which I should have tested... the function only works for 1D arrays. This will work. Have a nice day. Dave

Code:

---

Dim ArrTemp() As Variant, Arr() As Variant, Lr As Double
Dim Rng As Range, r As Range, Num As Integer
Lr = Sheets("Sheet1").Range("a65000").End(xlUp).Row
Set Rng = Sheets("Sheet1").Range("a1:a" & Lr).Cells
'fill 1D array with range
Cnt = 0
ReDim ArrTemp(Lr)
For Each r In Rng
ArrTemp(Cnt) = r.Value
Cnt = Cnt + 1
Next r
Arr = UniqueArr(ArrTemp)
'output for testing
For Num = LBound(Arr) To UBound(Arr)
MsgBox Arr(Num)
Next Num

---

Hi Team,

Dave,Snb,Paulked and vbax thanks for your help, its working perfectely now.:thumb


Regards,
mg