Custom Sorting a Collection of Class by Class Property

Question

I have a dilemma that I'm not sure how to approach head-on. I have three classes

A Segment Class, that has a Dictionary of Customer Classes, which in turn have Dictionaries of Product classes. The Dictionary of Customer classes needs to be sorted by a property of SumPoundsSold.

I honestly don't know where to start. Any hints?

I've figured it out and answered below. Also thanks to ainwood for posting Chip Pearson's code for sorting Collections/Dictionaries!

Answer 1

It is an old thread, I know, but I too had this need, and mine added sort an Array property by some index. But this is the last optional arg, it functions too for the OP question.

So, although I used things from this thread, very helpful, I preferred not use Dictionary - tons of legacy code already built in pure Collections... - I mainly adapted code from here and there.

Public Function SortIt(ByVal col As Collection, ByVal SortPropertyName As String _
            , ByVal AsAscending As Boolean, Optional ByVal KeyPropertyName As String _
            , Optional ByVal CallByNameArg As Variant) As Collection

Dim this As Object
Dim i As Integer, j As Integer
Dim MinMaxIndex As Integer
Dim MinMax As Variant, thisValue As Variant
Dim SortCondition As Boolean
Dim UseKey As Boolean, thisKey As String

    UseKey = (KeyPropertyName <> "")
    For i = 1 To col.Count - 1
        Set this = col(i)
        If IsMissing(CallByNameArg0) Then
            MinMax = CallByName(this, SortPropertyName, VbGet)
        Else
            MinMax = CallByName(this, SortPropertyName, VbGet, CallByNameArg)
        End If
        MinMaxIndex = i
        For j = i + 1 To col.Count
            Set this = col(j)
            If IsMissing(CallByNameArg0) Then
                thisValue = CallByName(this, SortPropertyName, VbGet)
            Else
                thisValue = CallByName(this, SortPropertyName, VbGet, CallByNameArg)
            End If
            If (AsAscending) Then
                SortCondition = (thisValue < MinMax)
            Else
                SortCondition = (thisValue > MinMax)
            End If
            If (SortCondition) Then
                MinMax = thisValue
                MinMaxIndex = j
            End If
            Set this = Nothing
        Next j
        If (MinMaxIndex <> i) Then
            Set this = col(MinMaxIndex)
            col.Remove MinMaxIndex
            If (UseKey) Then
                If IsMissing(CallByNameArg0) Then
                    thisKey = CallByName(this, KeyPropertyName, VbGet)
                Else
                    thisKey = CallByName(this, KeyPropertyName, VbGet, CallByNameArg)
                End If
                col.Add this, thisKey, i
            Else
                col.Add this, , i
            End If
            Set this = Nothing
        End If
        Set this = Nothing
    Next i
    Set SortIt = col
End Function

Hope it helps someone.

Answer 2

well, your solution works, but does extra unnecessary loops and it uses unnecessary helper functions...

As sorting dictionaries (and collections) in VBA is a bit of a mess, it is better to use a temporary array that you use to sort.

The full process would be:

1. check input & manage optional parameters
2. init auxiliary array to sort the elements
3. sort the elements in the array
4. build a new dictionary using the already sorted array

In the following example I just added one optional parameter to make your function reusable for customer dictionaries other than sCusomters variable:

Public Function SortByVolume(Optional Descending As Boolean = True, _
    Optional dicCustomers As Object = Nothing) As Object

 Dim blnInputParam As Boolean
 Dim pKey As Variant, I As Integer, J As Integer
 Dim arrSort() As Customer, blnSwap as Boolean
 Dim cusPosI As Customer, cusCur As Customer
 Dim dicTemp As Object

 On Error Resume Next

 Set SortByVolume = Nothing

 ' allow to use the function with other customer dictionaries
 blnInputParam = True
 If dicCustomers Is Nothing Then
    blnInputParam = False
    Set dicCustomers = sCustomers
 End If

 ' validate
 If dicCustomers is Nothing Then Exit Function
 If dicCustomers.Count = 0 Then Exit Function

 ' populate array
 ReDim arrSort(dicCustomers.Count - 1)
 I = 0
 For Each pKey In dicCustomers.Keys
    Set arrSort(I) = dicCustomers(pKey)
    I = I + 1
 Next

 ' sort array
 For I = LBound(arrSort) To UBound(arrSort) - 1
    Set cusPosI = arrSort(I)
    For J = I + 1 To UBound(arrSort)
        Set cusCur = arrSort(J)

        blnSwap = _
          (Descending AND (cusCur.SumPoundsSold > cusPosI.SumPoundsSold)) OR _
          ((Not Descending) AND (cusCur.SumPoundsSold < cusPosI.SumPoundsSold)

        If blnSwap Then
            Set arrSort(J) = cusPosI
            Set arrSort(I) = cusCur
            Set cusPosI = cusCur
        End If
    Next
 Next

 ' prepare output dictionary
 Set dicTemp = CreateObject("Scripting.Dictionary")
 dicTemp.CompareMode = BinaryCompare

 For I = LBound(arrSort) To UBound(arrSort)
    Set cusPosI = arrSort(I)
    dicTemp.Add cusPosI.pKey, cusPosI
 Next

 ' if input param wasn't used, set to default customers' dictionary
 If Not blnInputParam Then Set sCustomers = dicTemp
 Set SortByVolume = dicTemp
End Function

The usage

set myDicOfCustomers = SortByVolume(dicCustomers:=myDicOfCustomers)
set myDicOfCustomers = SortByVolume(Descending:=False, dicCustomers:=myDicOfCustomers)

' and you can still launch it against your default dictionary of customers like this
SortByVolume 
SortByVolume Descending:=False

Answer 3

I figured it out!

I can post the rest of the class, but basically it involves just finding the Minimum and Maximum value of the collection and then removing it once you've found it, and repeating the process until you reach a count of 0.

Here is my code

Public Sub SortByVolume(Optional Descending As Boolean = True)

    Dim TempDict As Dictionary
    Dim benchMark As Double 'The benchmark to start with and go from there

    Dim custCheck As Customer 'Customer to check during the loop

    'Make sure the Dictionary isn't nothing
    If sCustomers Is Nothing Then Exit Sub

    'If the count is 0 or 1 we don't need a sort
    If (sCustomers.Count = 0) Or (sCustomers.Count = 1) Then Exit Sub

    'Create the temprary dictionary
    Set TempDict = New Dictionary

    'We need to loop through the Dictionary to get the highest Volume
    'The Dictionary will load appending, so to descend we get the minimum value and build up, and vice versa for ascending
    If Descending = False Then
        benchMark = GetMaxVolume
    Else
        benchMark = GetMinVolume
    End If

    'Do everything until the benchmark is matched
    'Load everything into the TempDict, removing it from the original
    Do While sCustomers.Count > 0

        For Each pKey In sCustomers.Keys

            Set custCheck = sCustomers(pKey)
            If custCheck.SumPoundsSold = benchMark Then
                'benchmark has been met. Load this customer into TempDict
                TempDict.Add custCheck.Name, custCheck
                sCustomers.Remove pKey 'Remove the customer
                benchMark = IIf(Descending = True, GetMinVolume, GetMaxVolume)
                Set custCheck = Nothing
                Exit For
            End If

        Next pKey

    Loop

    'Set the Class' customer dictionary to the Temporary Dictionary
    Set sCustomers = TempDict

    'Set the TempDict to nothing
    Set TempDict = Nothing


End Sub

Public Function GetMaxVolume() As Double

    Dim highVol As Double: highVol = 0
    Dim checkCust As Customer

    For Each pKey In sCustomers.Keys
        Set checkCust = sCustomers(pKey)
        If checkCust.SumPoundsSold > highVol Then
            highVol = checkCust.SumPoundsSold
        End If
    Next pKey

    GetMaxVolume = highVol

End Function

Public Function GetMinVolume() As Double

    Dim lowVol As Double: lowVol = 1.79769313486232E+307
    Dim checkCust As Customer

    For Each pKey In sCustomers.Keys
        Set checkCust = sCustomers(pKey)
        If checkCust.SumPoundsSold <= lowVol Then
            lowVol = checkCust.SumPoundsSold
        End If
    Next pKey

    GetMinVolume = lowVol

End Function

Answer 4

Chip Pearson has This really good page on VBA Dictionaries. It includes how to convert collections, arrays and ranges to dictionaries (or to each other), and also how to sort dictionaries.

The (quite long!) code for dictionary sorting is as follows:

Use:

Public Sub SortDictionary(Dict As Scripting.Dictionary, _
SortByKey As Boolean, _
Optional Descending As Boolean = False, _
Optional CompareMode As VbCompareMethod = vbTextCompare)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortDictionary
' This sorts a Dictionary object. If SortByKey is False, the
' the sort is done based on the Items of the Dictionary, and
' these items must be simple data types. They may not be
' Object, Arrays, or User-Defined Types. If SortByKey is True,
' the Dictionary is sorted by Key value, and the Items in the
' Dictionary may be Object as well as simple variables.
'
' If sort by key is True, all element of the Dictionary
' must have a non-blank Key value. If Key is vbNullString
' the procedure will terminate.
'
' By defualt, sorting is done in Ascending order. You can
' sort by Descending order by setting the Descending parameter
' to True.
'
' By default, text comparisons are done case-INSENSITIVE (e.g.,
' "a" = "A"). To use case-SENSITIVE comparisons (e.g., "a" <> "A")
' set CompareMode to vbBinaryCompare.
'
' Note: This procedure requires the
' QSortInPlace function, which is described and available for
' download at www.cpearson.com/excel/qsort.htm .
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Ndx As Long
Dim KeyValue As String
Dim ItemValue As Variant
Dim Arr() As Variant
Dim KeyArr() As String
Dim VTypes() As VbVarType


Dim V As Variant
Dim SplitArr As Variant

Dim TempDict As Scripting.Dictionary
'''''''''''''''''''''''''''''
' Ensure Dict is not Nothing.
'''''''''''''''''''''''''''''
If Dict Is Nothing Then
    Exit Sub
End If
''''''''''''''''''''''''''''
' If the number of elements
' in Dict is 0 or 1, no
' sorting is required.
''''''''''''''''''''''''''''
If (Dict.Count = 0) Or (Dict.Count = 1) Then
    Exit Sub
End If

''''''''''''''''''''''''''''
' Create a new TempDict.
''''''''''''''''''''''''''''
Set TempDict = New Scripting.Dictionary

If SortByKey = True Then
''''''''''''''''''''''''''''''''''''''''
' We're sorting by key. Redim the Arr
' to the number of elements in the
' Dict object, and load that array
' with the key names.
''''''''''''''''''''''''''''''''''''''''
ReDim Arr(0 To Dict.Count - 1)

For Ndx = 0 To Dict.Count - 1
    Arr(Ndx) = Dict.Keys(Ndx)
Next Ndx

''''''''''''''''''''''''''''''''''''''
' Sort the key names.
''''''''''''''''''''''''''''''''''''''
QSortInPlace InputArray:=Arr, LB:=-1, UB:=-1, Descending:=Descending, CompareMode:=CompareMode
''''''''''''''''''''''''''''''''''''''''''''
' Load TempDict. The key value come from
' our sorted array of keys Arr, and the
' Item comes from the original Dict object.
''''''''''''''''''''''''''''''''''''''''''''
For Ndx = 0 To Dict.Count - 1
    KeyValue = Arr(Ndx)
    TempDict.Add Key:=KeyValue, Item:=Dict.Item(KeyValue)
Next Ndx
'''''''''''''''''''''''''''''''''
' Set the passed in Dict object
' to our TempDict object.
'''''''''''''''''''''''''''''''''
Set Dict = TempDict
''''''''''''''''''''''''''''''''
' This is the end of processing.
''''''''''''''''''''''''''''''''
Else
'''''''''''''''''''''''''''''''''''''''''''''''
' Here, we're sorting by items. The Items must
' be simple data types. They may NOT be Objects,
' arrays, or UserDefineTypes.
' First, ReDim Arr and VTypes to the number
' of elements in the Dict object. Arr will
' hold a string containing
'   Item & vbNullChar & Key
' This keeps the association between the
' item and its key.
'''''''''''''''''''''''''''''''''''''''''''''''
ReDim Arr(0 To Dict.Count - 1)
ReDim VTypes(0 To Dict.Count - 1)

For Ndx = 0 To Dict.Count - 1
    If (IsObject(Dict.Items(Ndx)) = True) Or _
        (IsArray(Dict.Items(Ndx)) = True) Or _
        VarType(Dict.Items(Ndx)) = vbUserDefinedType Then
        Debug.Print "***** ITEM IN DICTIONARY WAS OBJECT OR ARRAY OR UDT"
        Exit Sub
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Here, we create a string containing
    '       Item & vbNullChar & Key
    ' This preserves the associate between an item and its
    ' key. Store the VarType of the Item in the VTypes
    ' array. We'll use these values later to convert
    ' back to the proper data type for Item.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Arr(Ndx) = Dict.Items(Ndx) & vbNullChar & Dict.Keys(Ndx)
        VTypes(Ndx) = VarType(Dict.Items(Ndx))

Next Ndx
''''''''''''''''''''''''''''''''''
' Sort the array that contains the
' items of the Dictionary along
' with their associated keys
''''''''''''''''''''''''''''''''''
QSortInPlace InputArray:=Arr, LB:=-1, UB:=-1, Descending:=Descending, CompareMode:=vbTextCompare

For Ndx = LBound(Arr) To UBound(Arr)
    '''''''''''''''''''''''''''''''''''''
    ' Loop trhogh the array of sorted
    ' Items, Split based on vbNullChar
    ' to get the Key from the element
    ' of the array Arr.
    SplitArr = Split(Arr(Ndx), vbNullChar)
    ''''''''''''''''''''''''''''''''''''''''''
    ' It may have been possible that item in
    ' the dictionary contains a vbNullChar.
    ' Therefore, use UBound to get the
    ' key value, which will necessarily
    ' be the last item of SplitArr.
    ' Then Redim Preserve SplitArr
    ' to UBound - 1 to get rid of the
    ' Key element, and use Join
    ' to reassemble to original value
    ' of the Item.
    '''''''''''''''''''''''''''''''''''''''''
    KeyValue = SplitArr(UBound(SplitArr))
    ReDim Preserve SplitArr(LBound(SplitArr) To UBound(SplitArr) - 1)
    ItemValue = Join(SplitArr, vbNullChar)
    '''''''''''''''''''''''''''''''''''''''
    ' Join will set ItemValue to a string
    ' regardless of what the original
    ' data type was. Test the VTypes(Ndx)
    ' value to convert ItemValue back to
    ' the proper data type.
    '''''''''''''''''''''''''''''''''''''''
    Select Case VTypes(Ndx)
        Case vbBoolean
            ItemValue = CBool(ItemValue)
        Case vbByte
            ItemValue = CByte(ItemValue)
        Case vbCurrency
            ItemValue = CCur(ItemValue)
        Case vbDate
            ItemValue = CDate(ItemValue)
        Case vbDecimal
            ItemValue = CDec(ItemValue)
        Case vbDouble
            ItemValue = CDbl(ItemValue)
        Case vbInteger
            ItemValue = CInt(ItemValue)
        Case vbLong
            ItemValue = CLng(ItemValue)
        Case vbSingle
            ItemValue = CSng(ItemValue)
        Case vbString
            ItemValue = CStr(ItemValue)
        Case Else
            ItemValue = ItemValue
    End Select
    ''''''''''''''''''''''''''''''''''''''
    ' Finally, add the Item and Key to
    ' our TempDict dictionary.

    TempDict.Add Key:=KeyValue, Item:=ItemValue
Next Ndx
End If


'''''''''''''''''''''''''''''''''
' Set the passed in Dict object
' to our TempDict object.
'''''''''''''''''''''''''''''''''
Set Dict = TempDict
End Sub

Note the requirement for the QSortInPlace code. I won't paste that here... you can get it from This Link