我在VBA中使用CreateObject("Scripting.Dictionary")创建了一个词典，它将源词映射到某些文本中要替换的目标词（这实际上是用于混淆）。
不幸的是，当我按照下面的代码进行实际替换时，它将按照添加到字典中的顺序替换源字。如果我那么，例如＆＃34;蓝＆＃34;然后＆＃34; Blue Berry＆＃34;＆＃34; Blue＆＃34;参与＆＃34; Blue Berry＆＃34;取而代之的是第一个目标和＆＃34;浆果＆＃34;仍然保持原样。
'This is where I replace the values
For Each curKey In dctRepl.keys()
largeTxt = Replace(largeTxt, curKey, dctRepl(curKey))
Next
我认为我可以通过首先将字典的键从最长到最短的长度排序，然后按照上面的方式进行替换来解决此问题。问题是我不知道如何按这种方式对键进行排序。
答案 0 :(得分：13)
看起来我自己想出来了。我创建了以下似乎正在完成工作的功能：
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
Next
'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
Next
Next
'Create the new dictionary
Set funcSortKeysByLengthDesc = CreateObject("Scripting.Dictionary")
For itX = 0 To (dctList.Count - 1)
funcSortKeysByLengthDesc.Add arrTemp(itX), dctList(arrTemp(itX))
Next
Else
Set funcSortKeysByLengthDesc = dctList
End If
End Function
有关静态数组的更多信息，请参阅：https://excelmacromastery.com/excel-vba-array/#Declaring_an_Array
答案 1 :(得分：5)
我正在寻找一个简单的VBA函数，通过在Microsoft Excel中提升键值来对字典进行排序。
我对neelsg的代码进行了一些小的更改以符合我的目的（有关更改的详细信息，请参阅以下'//条评论）：
'/* Wrapper (accurate function name) */
Public Function funcSortDictByKeyAscending(dctList As Object) As Object
Set funcSortDictByKeyAscending = funcSortKeysByLengthDesc(dctList)
End Function
'/* neelsg's code (modified) */
Public Function funcSortKeysByLengthDesc(dctList As Object) As Object
'// Dim arrTemp() As String
Dim arrTemp() As Variant
...
...
...
'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
If arrTemp(itX) > arrTemp(itY) Then
...
...
...
'Create the new dictionary
'// Set funcSortKeysByLengthDesc = CreateObject("Scripting.Dictionary")
Set d = CreateObject("Scripting.Dictionary")
For itX = 0 To (dctList.Count - 1)
'// funcSortKeysByLengthDesc.Add arrTemp(itX), dctList(arrTemp(itX))
d(arrTemp(itX)) = dctList(arrTemp(itX))
Next
'// Added:
Set funcSortKeysByLengthDesc = d
Else
Set funcSortKeysByLengthDesc = dctList
End If
End Function
答案 2 :(得分：0)
我知道这是一个旧线程，但是当我遇到类似问题时它很有用。我的解决方案是使用Sandbox工作表，然后让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
答案 3 :(得分：0)
另一种可能性是使用ArrayList对Dictionary键进行排序，然后使用ArrayList值重新创建Dictionary。
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)
Next
oArrayList.Sort
''oArrayList.Reverse
' 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
Next
' Replace the old dictionary with new sorted dictionary.
Set oDictionary = oNewDictionary
Set oNewDictionary = Nothing: Set oArrayList = Nothing
On Error GoTo 0
End Sub