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

[malleshg24]

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

[Dave]

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

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...

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 :)

[malleshg24]

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

[paulked]

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

[大灰狼1976]

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

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

[paulked]

That's neat Wolfie :thumb

[大灰狼1976]

@paulked
:beerchug:

[snb]

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

[Dave]

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

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

[malleshg24]

Hi Team,

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


Regards,
mg