Public Function funcSortKeysByLengthDesc(dctList As Object) As Object 
    Dim arrTemp() As String
    Dim curKey As Variant
    Dim itX As Integer
    Dim itY As Integer

'Only sort if more than one item in the dict
    If dctList.Count > 1 Then

'Populate the array
        ReDim arrTemp(dctList.Count - 1)
        itX = 0
        For Each curKey In dctList
            arrTemp(itX) = curKey
            itX = itX + 1

'Do the sort in the array
        For itX = 0 To (dctList.Count - 2)
            For itY = (itX + 1) To (dctList.Count - 1)
                If Len(arrTemp(itX)) < Len(arrTemp(itY)) Then
                    curKey = arrTemp(itY)
                    arrTemp(itY) = arrTemp(itX)
                    arrTemp(itX) = curKey
                End If

'Create the new dictionary
        Set funcSortKeysByLengthDesc = CreateObject("Scripting.Dictionary")
        For itX = 0 To (dctList.Count - 1)
            funcSortKeysByLengthDesc.Add arrTemp(itX), dctList(arrTemp(itX))

        Set funcSortKeysByLengthDesc = dctList
    End If
End Function

Private Sub SortDictionary(oDictionary As Scripting.Dictionary) 
On Error Resume Next
Dim oArrayList As Object
Dim oNewDictionary As Scripting.Dictionary
Dim vKeys As Variant, vKey As Variant
   Set oArrayList = CreateObject("System.Collections.ArrayList")

' Transpose Keys into ones based array.
   vKeys = oDictionary.Keys
   vKeys = Application.WorksheetFunction.Transpose(vKeys)
   For Each vKey In vKeys
       Call oArrayList.Add(vKey)
' Create a new dictionary with the same characteristics as the old dictionary.
   Set oNewDictionary = New Scripting.Dictionary
   oNewDictionary.CompareMode = oDictionary.CompareMode

' Iterate over the array list and transfer values from old dictionary to new dictionary.
   For Each vKey In oArrayList
       sKey = CStr(vKey)
       If oDictionary.Exists(sKey) Then
           Call oNewDictionary.Add(sKey, oDictionary.Item(sKey))
       End If

' Replace the old dictionary with new sorted dictionary.
   Set oDictionary = oNewDictionary
   Set oNewDictionary = Nothing: Set oArrayList = Nothing
End Sub

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited TopPrevNext