VBA遍历A列匹配大写加粗值构建字典代码无输出排查

现有代码核心问题 #

• 集合对象仅在循环外初始化1次，所有字典键会共用同一个集合，出现内容混存
• 内层遍历逻辑未移动单元格指针，rng始终停在当前找到的标题单元格位置，且内层循环判断条件与需求相反（要求收集非加粗非大写的内容，原代码判断rng.Font.Bold = True），循环永远不会触发执行，因此集合计数始终为0
• 未做遍历边界判断，存在超出A1:A50范围的风险
• 未跳过作为键的标题单元格本身，容易把标题值错误计入内容集合

修正后完整代码 #

Function Pairs() As Dictionary
    Call Files
    With tg
        Dim pp As New Dictionary
        Dim currentRng As Range
        Dim titleKey As Variant
        Dim contentCol As Collection
        Const traverseEndRow As Long = 50
        
        Set currentRng = .Range("A1")
        Do While currentRng.Row <= traverseEndRow
            ' 匹配标题单元格规则：非空、不等于NULL、加粗、取值全大写
            If Not IsEmpty(currentRng.Value) And _
               currentRng.Value <> "NULL" And _
               currentRng.Font.Bold = True And _
               IsUpper(currentRng.Value) Then
                
                titleKey = currentRng.Value
                ' 每个标题对应独立的集合实例，避免内容串扰
                Set contentCol = New Collection
                
                ' 从标题下一行开始收集内容
                Set currentRng = currentRng.Offset(1, 0)
                Do While currentRng.Row <= traverseEndRow
                    ' 碰到下一个符合规则的标题，终止当前内容收集
                    If Not IsEmpty(currentRng.Value) And _
                       currentRng.Value <> "NULL" And _
                       currentRng.Font.Bold = True And _
                       IsUpper(currentRng.Value) Then
                        Exit Do
                    End If
                    ' 非空单元格加入当前内容集合
                    If Not IsEmpty(currentRng.Value) Then
                        contentCol.Add currentRng.Value
                    End If
                    ' 逐行下移单元格，原代码缺失该逻辑
                    Set currentRng = currentRng.Offset(1, 0)
                Loop
                
                ' 标题与对应内容集合存入字典
                pp.Add titleKey, contentCol
            Else
                ' 非标题单元格直接下移遍历
                Set currentRng = currentRng.Offset(1, 0)
            End If
        Loop
        
        Set Pairs = pp
    End With
End Function

' 全大写判断辅助函数，若工程内已有同名实现可忽略
Function IsUpper(val As Variant) As Boolean
    If VarType(val) <> vbString Then
        IsUpper = False
        Exit Function
    End If
    IsUpper = (UCase(val) = val)
End Function

效果验证 #

• 修正后执行MsgBox Pairs.Items(0).Count可正常返回第一个标题对应的内容条目数
• 不同标题对应的内容完全隔离，不会出现跨标题内容混存
• 遍历逻辑自动移动单元格指针，无死循环、内容漏取问题

内容的提问来源于stack exchange，提问作者Jia Hannah