如何用Scripting Dictionary按规则识别字符串变体并高亮表格目标行？

需求规则 #

• 同一客户编号下所有行Provision均为"Bad"：不做处理
• 同一客户编号下Provision包含"RR"与"Bad"混合：不做处理
• 同一客户编号下所有有效行（排除规则外）Provision均为"RR"：高亮这些行
• 排除规则：跳过Category为"XO"且Provision为"Exc"的行（不参与状态判断和高亮）

原始表格数据 #

现有代码问题 #

当前代码仅能高亮Provision为"RR"的行，但未判断同一客户编号下是否存在"Bad"行，无法满足规则中"排除含Bad客户的RR行"的要求。

原代码：

Option Explicit
Public Sub test()
Application.ScreenUpdating = False
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim z, y, rg, urg As Range
Dim r As Long, ar
Dim x As Variant: x = RGB(200, 205, 5)
Dim colDx, colTx, colvM As String
With ActiveSheet
   Dim tb As ListObject: Set tb = .ListObjects(1)
   Set z = tb.ListColumns("Customer Number").DataBodyRange
   Set y = tb.ListColumns("Category").DataBodyRange
  Set rg = Intersect(.UsedRange, .Range(z, y))
                ar = rg.Value
                 End With
 For r = 1 To UBound(ar) 'loop in the tb
    colDx = Trim(ar(r, tb.ListColumns("Provision").Index)) 'column provision
    colTx = Trim(ar(r, tb.ListColumns("Category").Index)) 'column category
    If UCase(colDx) <> "EXC" Then 'if not provision is Exc
    If UCase(colTx) = "XX" Then 'if the category is XX
    colDx = Trim(ar(r, tb.ListColumns("Provision").Index))
    colvM = Trim(ar(r, tb.ListColumns("Customer Number").Index))
       If dict.Exists(colvM) Then
           'if what stored in dict and the new value matching
              If StrComp(colDx, dict(colvM), vbTextCompare) = 0 Then
               If urg Is Nothing Then
                 Set urg = rg.Rows(r)
                         Else
                            Set urg = Union(urg, rg.Rows(r))
                          End If 'Urg
                      End If 'Strcomp
                    Else
                       dict.Add colvM, colDx ' add the customer number and the provision
                  End If 'dict exists
          End If 'XX
    End If 'EXC
 Next r
 If Not urg Is Nothing Then
 rg.Interior.ColorIndex = xlNone
 urg.Interior.Color = x
 End If
Application.ScreenUpdating = True
End Sub

修正后的代码 #

Option Explicit
Public Sub HighlightValidRRRows()
    Application.ScreenUpdating = False
    
    Dim tb As ListObject
    Set tb = ActiveSheet.ListObjects(1)
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim ar As Variant
    ar = tb.DataBodyRange.Value
    
    Dim r As Long
    Dim custNum As String, provision As String, category As String
    
    ' 第一步：遍历所有行，记录每个客户的状态（是否含Bad、是否全为RR）
    For r = 1 To UBound(ar)
        custNum = Trim(ar(r, tb.ListColumns("客户编号").Index))
        provision = UCase(Trim(ar(r, tb.ListColumns("Provision").Index)))
        category = UCase(Trim(ar(r, tb.ListColumns("Category").Index)))
        
        ' 跳过排除规则的行，不参与状态判断
        If Not (category = "XO" And provision = "EXC") Then
            If Not dict.Exists(custNum) Then
                ' 字典存储数组：[是否存在Bad, 是否全为RR]
                dict(custNum) = Array(False, True)
            End If
            
            Dim statusArr As Variant
            statusArr = dict(custNum)
            
            ' 更新客户状态
            If provision = "BAD" Then
                statusArr(0) = True
                statusArr(1) = False ' 存在Bad则不可能全为RR
            ElseIf provision <> "RR" Then
                ' 存在非RR的有效行，标记为不全是RR
                statusArr(1) = False
            End If
            
            dict(custNum) = statusArr
        End If
    Next r
    
    ' 第二步：遍历所有行，高亮符合条件的行
    tb.DataBodyRange.Interior.ColorIndex = xlNone ' 清除原有高亮
    
    Dim targetRange As Range
    For r = 1 To UBound(ar)
        custNum = Trim(ar(r, tb.ListColumns("客户编号").Index))
        provision = UCase(Trim(ar(r, tb.ListColumns("Provision").Index)))
        category = UCase(Trim(ar(r, tb.ListColumns("Category").Index)))
        
        ' 跳过排除规则的行
        If Not (category = "XO" And provision = "EXC") Then
            Dim statusArr As Variant
            statusArr = dict(custNum)
            
            ' 仅当客户无Bad且全为RR时，高亮该行
            If statusArr(0) = False And statusArr(1) = True And provision = "RR" Then
                If targetRange Is Nothing Then
                    Set targetRange = tb.DataBodyRange.Rows(r)
                Else
                    Set targetRange = Union(targetRange, tb.DataBodyRange.Rows(r))
                End If
            End If
        End If
    Next r
    
    ' 应用高亮颜色
    If Not targetRange Is Nothing Then
        targetRange.Interior.Color = RGB(200, 205, 5)
    End If
    
    Application.ScreenUpdating = True
End Sub

代码说明 #

1. 状态记录逻辑：用字典存储每个客户的两个核心状态，解决原代码未跟踪客户整体状态的问题
2. 两步遍历机制：先统计客户状态，再根据状态筛选高亮行，逻辑清晰且高效
3. 排除规则实现：明确跳过Category=XO且Provision=Exc的行，不参与任何判断
4. 精准高亮判断：仅对"无Bad行且所有有效行均为RR"的客户的RR行进行高亮，完全匹配需求规则

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