如何在VBA中按嵌套字典的Salary和Revenue排序并取Top3？

问题描述 #

现有Excel样本数据，已通过VBA构建嵌套字典结构：

• 主字典MainDict：以姓名（Name）为Key，嵌套字典为Item
• 嵌套字典：Key为"Salary"、"Revenue"、"Position"，对应存储薪资、营收、职位数据

需要解决：

1. 获取Salary值最高的前3个姓名
2. 获取Revenue值最高的前3个姓名
3. 在不预先排序Excel数据的前提下，基于嵌套字典的项对主字典进行排序

现有代码说明 #

字典构建代码 #

注意：原代码中更新Revenue的逻辑存在错误，已修正（将累加时的Salary字段改为Revenue）：

Dim MainDict As New Scripting.Dictionary
Dim NestedDict As Scripting.Dictionary
    
Dim rngRange As Range
Set rngRange = wsMainWorkSheet.Range("B2:E8")

Dim rowCounter As Long
  
For rowCounter = 1 To rngRange.Rows.Count
    Set NestedDict = New Dictionary
    NestedDict.Add key:="Salary", Item:=rngRange(rowCounter, 2)
    NestedDict.Add key:="Revenue", Item:=rngRange(rowCounter, 3)
    NestedDict.Add key:="Position", Item:=rngRange(rowCounter, 4)
    
    Dim mainKey As String
    mainKey = CStr(rngRange(rowCounter, 1))
    If MainDict.Exists(mainKey) = False Then
        MainDict.Add key:=mainKey, Item:=NestedDict
    Else:
        MainDict.Item(mainKey)("Salary") = MainDict.Item(mainKey)("Salary") + rngRange(rowCounter, 2)
        ' 修正原代码错误：更新Revenue时应使用自身字段累加
        MainDict.Item(mainKey)("Revenue") = MainDict.Item(mainKey)("Revenue") + rngRange(rowCounter, 3)
    End If
Next rowCounter

字典打印代码 #

Sub PrintDictionary(dict As Dictionary)
Dim key As Variant, subKey As Variant

For Each key In dict.Keys
    Debug.Print vbNewLine; "Name: " & key
    For Each subKey In dict(key).Keys
        Debug.Print subKey & ": " & dict(key)(subKey)
    Next subKey
Next key
End Sub

解决方案 #

1. 获取TopN姓名（薪资/营收前三） #

利用System.Collections.ArrayList实现排序，通过通用函数可快速获取指定字段的TopN姓名：

' 通用函数：获取指定字段排序后的前N个姓名
' 参数：mainDict-主字典；sortKey-排序字段（"Salary"/"Revenue"）；topN-需要获取的数量
Function GetTopNNames(mainDict As Scripting.Dictionary, sortKey As String, topN As Integer) As Variant
    Dim arrList As Object
    Dim key As Variant
    Dim result() As String
    Dim i As Integer
    
    Set arrList = CreateObject("System.Collections.ArrayList")
    
    ' 将姓名与对应字段值存入ArrayList
    For Each key In mainDict.Keys
        arrList.Add Array(key, mainDict(key)(sortKey))
    Next key
    
    ' 先升序排序，再反转得到降序
    arrList.Sort
    arrList.Reverse
    
    ' 提取前N个姓名（处理数据不足topN的情况）
    ReDim result(1 To topN)
    For i = 0 To topN - 1
        If i < arrList.Count Then
            result(i + 1) = arrList(i)(0)
        Else
            result(i + 1) = ""
        End If
    Next i
    
    GetTopNNames = result
End Function

' 测试获取Top3
Sub TestTop3()
    Dim salaryTop3 As Variant
    Dim revenueTop3 As Variant
    Dim i As Integer
    
    salaryTop3 = GetTopNNames(MainDict, "Salary", 3)
    Debug.Print "薪资Top3姓名："
    For i = 1 To 3
        If salaryTop3(i) <> "" Then Debug.Print salaryTop3(i)
    Next i
    
    revenueTop3 = GetTopNNames(MainDict, "Revenue", 3)
    Debug.Print vbNewLine & "营收Top3姓名："
    For i = 1 To 3
        If revenueTop3(i) <> "" Then Debug.Print revenueTop3(i)
    Next i
End Sub

2. 基于嵌套字典项排序主字典 #

VBA的Scripting.Dictionary本身不支持原生排序（旧版本按插入顺序存储，新版本虽有Sort方法但兼容性差），可通过以下方式实现排序：

方法：获取排序后的键数组

通过ArrayList排序后提取键数组，后续遍历字典时使用该数组即可按指定顺序访问：

' 通用函数：获取指定字段排序后的键数组
' 参数：mainDict-主字典；sortKey-排序字段；isDescending-是否降序（默认True）
Function GetSortedKeys(mainDict As Scripting.Dictionary, sortKey As String, Optional isDescending As Boolean = True) As Variant
    Dim arrList As Object
    Dim key As Variant
    Dim sortedKeys() As String
    Dim i As Integer
    
    Set arrList = CreateObject("System.Collections.ArrayList")
    
    For Each key In mainDict.Keys
        arrList.Add Array(key, mainDict(key)(sortKey))
    Next key
    
    arrList.Sort
    If isDescending Then arrList.Reverse
    
    ' 提取排序后的姓名键
    ReDim sortedKeys(1 To arrList.Count)
    For i = 0 To arrList.Count - 1
        sortedKeys(i + 1) = arrList(i)(0)
    Next i
    
    GetSortedKeys = sortedKeys
End Function

' 测试按薪资降序遍历字典
Sub TestSortedDict()
    Dim sortedSalaryKeys As Variant
    Dim i As Integer
    
    sortedSalaryKeys = GetSortedKeys(MainDict, "Salary")
    
    Debug.Print vbNewLine & "按薪资降序排序的结果："
    For i = 1 To UBound(sortedSalaryKeys)
        Debug.Print "姓名：" & sortedSalaryKeys(i) & _
                    " | 薪资：" & MainDict(sortedSalaryKeys(i))("Salary") & _
                    " | 营收：" & MainDict(sortedSalaryKeys(i))("Revenue")
    Next i
End Sub

可选：构建排序后的新字典

若需要一个保持排序顺序的字典（仅兼容Office 365及以上版本，因为新版本字典保留插入顺序），可基于排序后的键数组重新构建：

' 构建按指定字段排序后的新字典
Function GetSortedDict(mainDict As Scripting.Dictionary, sortKey As String, Optional isDescending As Boolean = True) As Scripting.Dictionary
    Dim sortedKeys As Variant
    Dim key As Variant
    Dim newDict As New Scripting.Dictionary
    
    sortedKeys = GetSortedKeys(mainDict, sortKey, isDescending)
    
    For Each key In sortedKeys
        newDict.Add key, mainDict(key)
    Next key
    
    Set GetSortedDict = newDict
End Function

内容的提问来源于stack exchange，提问作者Erba Aitbayev