我知道这是一个旧的主题,但当我遇到类似的问题时它很有帮助。我的解决方案是使用沙盒工作表,让Excel对键进行排序,然后重新构建字典。通过使用沙盒工作表,您可以非常容易地使用公式来处理其他困难的排序情况,而无需编写自己的冒泡排序。对于原始帖子的情况,按Len(Key)降序排序将解决问题。
这是我的代码:
Private Sub SortDictionary(oDictionary As Scripting.Dictionary, oSandboxSheet As Worksheet)
On Error Resume Next
Dim oSortRange As Range
Dim oNewDictionary As Scripting.Dictionary
Dim lBegRow As Long, lEndRow As Long, lBegCol As Long, lEndCol As Long
Dim lIndex As Long
Dim sKey As String
Dim vKeys As Variant
' Transpose Keys into ones based array.
vKeys = oDictionary.Keys
vKeys = Application.WorksheetFunction.Transpose(vKeys)
' Calculate sheet rows and columns based upon array dimensions.
lBegRow = LBound(vKeys, 1): lEndRow = UBound(vKeys, 1)
lBegCol = LBound(vKeys, 2): lEndCol = UBound(vKeys, 2)
With oSandboxSheet
.Activate
.Cells.EntireColumn.Clear
' Copy the keys to Excel Range calculated from Keys array dimensions.
.Range(.Cells(lBegRow, lBegCol), .Cells(lEndRow, lEndCol)).Value = vKeys
.Cells.EntireColumn.AutoFit
' Sort the entire range.
Set oSortRange = .Range(.Cells(lBegRow, lBegCol), .Cells(lEndRow, lEndCol))
With .Sort
With .SortFields
.Clear
Call .Add(Key:=oSortRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal)
End With
Call .SetRange(oSortRange)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Recreate the keys now sorted as desired.
vKeys = .Range(.Cells(lBegRow, lBegCol), .Cells(lEndRow, lEndCol)).Value
End With
' Create a new dictionary with the same characteristics as the old dictionary.
Set oNewDictionary = New Scripting.Dictionary
oNewDictionary.CompareMode = oDictionary.CompareMode
' Iterate over the new sorted keys and transfer values from old dictionary to new dictionary.
For lIndex = LBound(vKeys, 1) To UBound(vKeys, 1)
sKey = vKeys(lIndex, 1)
If oDictionary.Exists(sKey) Then
Call oNewDictionary.Add(sKey, oDictionary.Item(sKey))
End If
Next
' Replace the old dictionary with new sorted dictionary.
Set oDictionary = oNewDictionary
Set oNewDictionary = Nothing: Set oSortRange = Nothing
On Error GoTo 0
End Sub