数组（Array）中自定义对象按多属性高效分级分组方案咨询

方案核心思路 #

使用VBA内置的Dictionary（字典）对象实现动态分组，不需要手动维护已处理值数组和多层嵌套遍历，逻辑可扩展，增加分组维度只需要加一层字典即可。

前置准备 #

字典支持两种调用方式，可按需选择：

• 前期绑定：VBA编辑器点击「工具」-「引用」，勾选「Microsoft Scripting Runtime」，直接声明Dim dict As New Dictionary
• 后期绑定：无需修改引用，声明为Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

补充说明：如果需要分组属性不区分大小写，可以在创建字典后设置dict.CompareMode = 1即可。

示例1：按毛色→是否带斑点两级分组（对应你的狗对象需求） #

Sub GroupDogs()
    ' 假设已经初始化好了狗对象数组 ArrayofObjectInstances
    Dim ArrayofObjectInstances() As SpecificObject
    ' 声明一级分组字典：Key=毛色，Value=二级分组字典
    Dim groupByColor As Object
    Set groupByColor = CreateObject("Scripting.Dictionary")
    Dim dog As SpecificObject
    
    ' 一次遍历完成所有分组，不需要多次循环数组
    For Each dog In ArrayofObjectInstances
        ' 先按毛色做一级分组
        If Not groupByColor.Exists(dog.Color) Then
            ' 该毛色第一次出现，新建对应的二级分组字典：Key=是否带斑点，Value=狗对象集合
            Set groupByColor(dog.Color) = CreateObject("Scripting.Dictionary")
        End If
        ' 再按是否带斑点做二级分组
        If Not groupByColor(dog.Color).Exists(dog.HasSpot) Then
            ' 该斑点属性第一次出现在当前毛色分组下，新建集合存对象
            Set groupByColor(dog.Color)(dog.HasSpot) = New Collection
        End If
        ' 将当前狗对象加入对应分组
        groupByColor(dog.Color)(dog.HasSpot).Add dog
    Next
    
    ' 使用示例：获取所有棕色带斑点的狗
    If groupByColor.Exists("棕色") And groupByColor("棕色").Exists(True) Then
        Dim targetDogs As Collection
        Set targetDogs = groupByColor("棕色")(True)
        ' 后续可以直接遍历targetDogs做逻辑处理
    End If
    
    ' 遍历所有分组做批量处理的示例
    Dim colorKey As Variant, spotKey As Variant
    For Each colorKey In groupByColor.Keys
        Debug.Print "毛色：" & colorKey
        For Each spotKey In groupByColor(colorKey).Keys
            Debug.Print "  是否带斑点：" & spotKey & "，数量：" & groupByColor(colorKey)(spotKey).Count
            ' 这里可以加你需要的子分组校验逻辑
        Next
    Next
End Sub

示例2：对应表格多列校验场景 #

如果是要按第一列分组，校验每组内是否存在第二、第三列值为b-z的组合，代码可以简化为：

Sub CheckTableGroups()
    ' 假设已经把表格数据存入对象数组，每个对象有Col1/Col2/Col3三个属性
    Dim arr() As TableObject
    Dim groupByCol1 As Object
    Set groupByCol1 = CreateObject("Scripting.Dictionary")
    Dim item As TableObject
    
    ' 一次遍历完成分组，同时完成校验标记
    For Each item In arr
        If Not groupByCol1.Exists(item.Col1) Then
            ' 每个分组新增时默认标记为「未找到符合条件的组合」
            groupByCol1(item.Col1) = False
        End If
        ' 如果当前行符合第二第三列取值要求，直接把分组标记改为True
        If item.Col2 >= "b" And item.Col2 <= "z" And item.Col3 >= "b" And item.Col3 <= "z" Then
            groupByCol1(item.Col1) = True
        End If
    Next
    
    ' 直接输出结果即可
    Dim key As Variant
    For Each key In groupByCol1.Keys
        Debug.Print "第一列值为" & key & "的分组" & IIf(groupByCol1(key), "存在", "不存在") & "符合条件的组合"
    Next
End Sub

方案优势 #

• 只需要遍历原数组1次即可完成所有层级的分组，时间复杂度远低于多层嵌套遍历方案
• 新增分组维度只需要对应加一层字典即可，不需要额外新增多个数组变量，可维护性极强
• 分组结果直接按键索引，不需要每次遍历数组找匹配项，读取效率极高

内容的提问来源于stack exchange，提问作者G.M