View Full Version : vba - Extract Unique values from Single Column via Colllection and Dictionary
malleshg24
11-18-2019, 01:15 PM
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
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
11-18-2019, 09:06 PM
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
11-18-2019, 09:25 PM
@mg What error do you get? Works perfectly well for me.
大灰狼1976
11-18-2019, 10:59 PM
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
11-18-2019, 11:15 PM
That's neat Wolfie :thumb
大灰狼1976
11-18-2019, 11:19 PM
@paulked
:beerchug:
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
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
11-20-2019, 12:06 PM
Hi Team,
Dave,Snb,Paulked and vbax thanks for your help, its working perfectely now.:thumb
Regards,
mg
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.