Filter and Sort Scripting Dictionary

I'm having an issue filtering and sorting a scripting dictionary. The macro I am using creates a dictionary and displays it on a userform. However, there repeated values in the dictionary, and the values are not in alphabetical order. Is it possible to do put the values in alphabetical order and remove the duplicates? Any help is appreciated.

Private dic As Object
 Private Sub UserForm_Initialize()
    Dim a, i As Long, w()
    With Sheets("Holdings For Export")
    a = .Range("D4103", .Range("d" & Rows.Count).End(xlUp)).Resize(, 25).Value
    End With

    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For i = 2 To UBound(a, 1)
        If Not dic.exists(a(i, 1)) Then dic.Item(a(i, 1)) = Empty
        If IsEmpty(dic.Item(a(i, 1))) Then
            ReDim w(0)
        Else
            w = dic.Item(a(i, 1))
            ReDim Preserve w(UBound(w) + 1)
        End If
        w(UBound(w)) = a(i, 25)
        dic.Item(a(i, 1)) = w
    Next
    Me.ManagerSellEntity.list = dic.keys
End Sub
 
Private Sub ManagerSellEntity_Click()
    Me.ManagerSellManager.list = dic(Me.ManagerSellEntity.Value)

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set dic = Nothing
End Sub

Dom,

Thanks for the quick reply. Looks like this will work, but I have one further question. Where would I integrate this function? To be honest, I'm pretty green when it comes to VBA. I added the code from your link, and integrated the relevant parts to my macro, but I get the error "type mismatch". Here's what I have thus far.

 

Private Sub UserForm_Initialize()
    Dim a, i As Long, w()
    Dim NoDupes As New Collection
    Dim T As Integer, j As Integer
    Dim Swap1, Swap2, Item
    
    With Sheets("Holdings For Export")
    a = .Range("D4103", .Range("d" & Rows.Count).End(xlUp)).Resize(, 25).Value
    End With

    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For i = 2 To UBound(a, 1)
        If Not dic.exists(a(i, 1)) Then dic.Item(a(i, 1)) = Empty
        If IsEmpty(dic.Item(a(i, 1))) Then
            ReDim w(0)
        Else
            w = dic.Item(a(i, 1))
            ReDim Preserve w(UBound(w) + 1)
        End If
        w(UBound(w)) = a(i, 25)
        dic.Item(a(i, 1)) = w
    Next
        Dim AllCells As Range, Cell As Range
    
    
'   The items are in A1:A105
    Set AllCells = dic
    
'   The next statement ignores the error caused
'   by attempting to add a duplicate key to the collection.
'   The duplicate is not added - which is just what we want!
    On Error Resume Next
    For Each Cell In AllCells
        NoDupes.Add Cell.Value, CStr(Cell.Value)
'       Note: the 2nd argument (key) for the Add method must be a string
    Next Cell

'   Resume normal error handling
    On Error GoTo 0

'   Sort the collection (optional)
    For T = 1 To NoDupes.Count - 1
        For j = T + 1 To NoDupes.Count
            If NoDupes(T) > NoDupes(j) Then
                Swap1 = NoDupes(T)
                Swap2 = NoDupes(j)
                NoDupes.Add Swap1, before:=j
                NoDupes.Add Swap2, before:=T
                NoDupes.Remove T + 1
                NoDupes.Remove j + 1
            End If
        Next j
    Next T
    Me.ManagerSellEntity.list = dic.keys
End Sub

hi Jbryce22, as a suggestion: if you are allowed to change the order of the range ("D4103" ...) rows you can sort it before proceeding with dupes elimination

Watersev,

That is one way to do it, but I would prefer to have that done in the scripting dictionary if possible. I'd rather not have to sort the data source unless there is no other way to accomplish this.

Hi,

Please upload your sample workbook to do vba activity.

Here's my workbook. Any help is greatly appreciated.

Sub Test_SortDictKeys()
  Dim i As Integer
  Dim a(0 To 5) As Variant, b() As Variant
  For i = 0 To 5
    a(i) = i
  Next i
  
  MsgBox Join(a, vbLf), vbInformation, "Original Array: With No Dups and Sorted"
  
  a(0) = 1 'Make a duplicate
  a(5) = 4
  a(4) = 5 'Make last two elements unsorted
  
  MsgBox Join(a, vbLf), vbInformation, "With A Dup"
  
  b() = UniqueArrayByDict(a)
  MsgBox Join(b, vbLf), vbInformation, "No Dup"
  
  QuickSort b()
  MsgBox Join(b, vbLf), vbInformation, "No Dup and Sorted"
End Sub

'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
  'Dim dic As Object 'Late Binding method - Requires no Reference
  'Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  Dim dic As Dictionary     'Early Binding method
  Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function

'http://home.pacbell.net/beban/
'Copyright 2000 Alan Beban
Sub QuickSort(ByRef VA_array, Optional V_Low1, Optional V_high1)
  On Error Resume Next
  
  'Dimension variables
  Dim V_Low2, V_high2, V_loop As Integer
  Dim V_val1, V_val2 As Variant
  
  'If first time, get the size of the array to sort
  If IsMissing(V_Low1) Then
      V_Low1 = LBound(VA_array, 1)
  End If
  
  If IsMissing(V_high1) Then
      V_high1 = UBound(VA_array, 1)
  End If
  
  'Set new extremes to old extremes
  V_Low2 = V_Low1
  V_high2 = V_high1
  
  'Get value of array item in middle of new extremes
  V_val1 = VA_array((V_Low1 + V_high1) / 2)
  
  'Loop for all the items in the array between the extremes
  While (V_Low2 <= V_high2)
  
      'Find the first item that is greater than the mid-point item
      While (VA_array(V_Low2) < V_val1 And V_Low2 < V_high1)
          V_Low2 = V_Low2 + 1
      Wend
  
      'Find the last item that is less than the mid-point item
      While (VA_array(V_high2) > V_val1 And V_high2 > V_Low1)
          V_high2 = V_high2 - 1
      Wend
  
      'If the new 'greater' item comes before the new 'less' item, swap them
      If (V_Low2 <= V_high2) Then
          V_val2 = VA_array(V_Low2)
          VA_array(V_Low2) = VA_array(V_high2)
          VA_array(V_high2) = V_val2
  
          'Advance the pointers to the next item
          V_Low2 = V_Low2 + 1
          V_high2 = V_high2 - 1
      End If
  Wend
  
  'Iterate to sort the lower half of the extremes
  If (V_high2 > V_Low1) Then Call QuickSort(VA_array, V_Low1, V_high2)
  
  'Iterate to sort the upper half of the extremes
  If (V_Low2 < V_high1) Then Call QuickSort(VA_array, V_Low2, V_high1)
End Sub

Kenneth, thanks for this. I'm having trouble integrating this. Is this supposed to be in lieu of my current macro, or in addition to? I'm not very well versed in VBA, and I apologize if this is annoying. I just really want to get this to work. Thanks!

Private dic As Object
 Public Sub UserForm_Initialize()
    Dim a, i As Long, w()
    With Sheets("Holdings For Export")
    a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
    End With

    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = 1
    For i = 2 To UBound(a, 1)
        If Not dic.Exists(a(i, 1)) Then dic.Item(a(i, 1)) = Empty
        If IsEmpty(dic.Item(a(i, 1))) Then
            ReDim w(0)
        Else
            w = dic.Item(a(i, 1))
            ReDim Preserve w(UBound(w) + 1)
        End If
        w(UBound(w)) = a(i, 3)
        dic.Item(a(i, 1)) = w
    Next
    
    Me.ManagerSellEntity.list = dic.Keys

End Sub



Private Sub ManagerSellEntity_Click()
  
    Me.ManagerSellManager.list = dic(Me.ManagerSellEntity.Value)

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set dic = Nothing
End Sub
Private Sub CloseWindow_Click()
Unload Me
End Sub

It should probably go something like:

 Public Sub UserForm_Initialize()
    Dim a, i As Long, w()
    Dim x() As Variant
    
    With Sheets("Holdings For Export")
    a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
    End With

    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    For i = 2 To UBound(a, 1)
        If Not dic.Exists(a(i, 1)) Then dic.Item(a(i, 1)) = Empty
        If IsEmpty(dic.Item(a(i, 1))) Then
            ReDim w(0)
        Else
            w = dic.Item(a(i, 1))
            ReDim Preserve w(UBound(w) + 1)
        End If
        w(UBound(w)) = a(i, 3)
        dic.Item(a(i, 1)) = w
    Next
    
    x() = dic.Keys
    QuickSort x()
    Me.ManagerSellEntity.List = x()

End Sub

Kenneth, again, thanks for your help. I wasn't able to get this to work. It's still not sorting or filtering. Do you have any other suggestions?

I am not sure what you mean by filter.

Your original code eliminates dups. My sort routine sorts it. You need to move your data out of sort order to see that. Of course your routine is only doing it for the first combobox. I am not why you resized the range to 3 if you only wanted the Column A data for combobox1.

My apologies. I think I misscommunicated. The reason I have my range set to 3 is because I would like for combobox2 to include the 3rd column in my data range (Manager). I should have clarified better my needs. I was hoping to have combobox2 sorted and the dupes removed from it. Using your quicksort, I am able to sort the combobox2, but I am unsure of how to remove the duplicates from it. Again, any help is appreciated. Many thanks, Kenneth.

You have some other issues after selecting the first one but this fills and sorts both comboboxes.

Public Sub UserForm_Initialize()
    Dim a() As Variant, lRow As Long
    
    With Sheets("Holdings For Export")
      lRow = .Range("A" & Rows.Count).End(xlUp).Row
      a() = WorksheetFunction.Transpose(.Range("A2:A" & lRow))
      a() = UniqueArrayByDict(a(), 1)
      QuickSort a()
      Me.ManagerSellEntity.List = a()
      a() = WorksheetFunction.Transpose(.Range("C2:C" & lRow))
      a() = UniqueArrayByDict(a(), 1)
      QuickSort a()
      Me.ManagerSellManager.List = a()
    End With
End Sub