11

我在 VBA 中创建了一个字典，使用CreateObject("Scripting.Dictionary")它将源词映射到要在某些文本中替换的目标词（这实际上是为了混淆）。

不幸的是，当我按照下面的代码进行实际替换时，它将按照源词添加到字典中的顺序替换它们。如果我有例如“Blue”然后是“Blue Berry”，“Blue Berry”中的“Blue”部分将被第一个目标替换，“Berry”保持原样。

'This is where I replace the values
For Each curKey In dctRepl.keys()
    largeTxt = Replace(largeTxt, curKey, dctRepl(curKey))
Next

我在想我可以通过首先将字典的键从最长长度排序到最短长度然后进行上述替换来解决这个问题。问题是我不知道如何以这种方式对键进行排序。

4

5 回答 5

15

看来我自己想通了。我创建了以下似乎正在完成这项工作的函数：

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

于 2013-02-11T08:39:57.827 回答
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
于 2014-11-24T15:22:47.457 回答
1

我知道这是一个旧线程，但是当我遇到类似问题时它很有帮助。我的解决方案是使用沙盒工作表，让 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
于 2020-06-20T12:18:29.760 回答
1

另一种可能性是使用 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
于 2020-07-03T22:14:05.350 回答
0

可以通过在过程中添加代码来对键进行排序，而无需创建函数。

Dim sdkey,tamp As Variant
With CreateObject("Scripting.Dictionary")
sdkey = .keys
For i = LBound(sdkey) + 1 To UBound(sdkey)    ' We've listed the unique values as alphabetically.
For j = LBound(sdkey) To UBound(sdkey) - 1
If sdkey(j) > sdkey(i) Then
tamp = sdkey(j)
sdkey(j) = sdkey(i)
sdkey(i) = tamp
End If
Next j
Next i

ReDim tamp(1 To UBound(sd_key) + 1, 1 To 2)
…

在此处输入图像描述

示例文件源：获取 Excel 中不同值的总和

于 2021-10-02T18:14:45.317 回答