Consulting

Results 1 to 10 of 10

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

  1. #1
    Banned VBAX Contributor
    Joined
    Aug 2017
    Posts
    144
    Location

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

    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
    Attached Files Attached Files

  2. #2
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    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

  3. #3
    Banned VBAX Contributor
    Joined
    Aug 2017
    Posts
    144
    Location
    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

  4. #4
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    @mg What error do you get? Works perfectly well for me.
    Semper in excretia sumus; solum profundum variat.

  5. #5
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    479
    Location
    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
    Attached Files Attached Files

  6. #6
    VBAX Master paulked's Avatar
    Joined
    Apr 2006
    Posts
    1,007
    Location
    That's neat Wolfie
    Semper in excretia sumus; solum profundum variat.

  7. #7
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    479
    Location
    @paulked

  8. #8
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

  9. #9
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    832
    Location
    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

  10. #10
    Banned VBAX Contributor
    Joined
    Aug 2017
    Posts
    144
    Location
    Hi Team,

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


    Regards,
    mg

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •