如何通过脚本字典识别已知类别的字符串真实性？

Question

我有一个表，需要添加限制角色以突出显示包含特定字符串类型的行并释放任何返回字符串验证的行。

我想要实现的角色是：

• 如果同一客户编号下的所有行都设置为“不良”，则可以。
• 如果同一客户编号下的所有行都混合在“RR”和“Bad”之间，那么这是可以的。
• 如果同一客户编号下的所有行都配置为“RR”，则突出显示这些行。

排除具有类别“XO”并从角色中配置为“Exc”的行

我的桌子：

客户编号	客户姓名	发票	供应	类别
55850	ABC	124587	Exc	XX
55850	ABC	124588	RR	XX
55850	ABC	124589	RR	XX
55850	ABC	124590	RR	XX
55850	ABC	124591	RR	XX
32336	防御	124592	不好	XO
32336	防御	124593	不好	XO
30131	GHI	124594	Exc	XX
30131	GHI	124595	RR	XX
30131	GHI	124596	RR	XX
13914	JKL	124597	Exc	XX
13914	JKL	124598	RR	XX
13914	JKL	124599	不好	XX
13914	JKL	124600	RR	XX

到目前为止，我的代码会突出显示配置为“RR”的行（这是必需的），但仍然不会忽略“RR”行中具有“Bad”行的客户编号。 非常感谢您的帮助，如果您需要更多说明，请告诉我。

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

Answer 1

• 使用两个

  Dictionary

  对象来跟踪每个客户的

  Provision

微软文档：

Range.Resize 属性 (Excel)

应用程序.Union方法（Excel）

Option Explicit

Sub Demo()
    Dim objDicBAD As Object, objDicRR As Object, rngData As Range
    Dim i As Long, sKey, ColCnt As Long
    Dim arrData, oTab As ListObject, rngHL As Range
    Dim ColCus As Long, ColPro As Long, ColCat As Long
    Set oTab = ActiveSheet.ListObjects(1)
    Set rngData = oTab.DataBodyRange
    ColCus = oTab.ListColumns("Customer Number").Index
    ColPro = oTab.ListColumns("Provision").Index
    ColCat = oTab.ListColumns("Category").Index
    ColCnt = oTab.ListColumns.Count
    ' Load table into array
    arrData = rngData.Value
    Set objDicBAD = CreateObject("scripting.dictionary")
    Set objDicRR = CreateObject("scripting.dictionary")
    ' Loop through table
    For i = LBound(arrData) To UBound(arrData)
        sKey = arrData(i, ColCus)
        Select Case UCase(arrData(i, ColPro))
        Case "RR"
            If objDicRR.exists(sKey) Then
                Set objDicRR(sKey) = Application.Union(objDicRR(sKey), Cells(i + 1, ColCus).Resize(1, ColCnt))
            Else
                Set objDicRR(sKey) = Cells(i + 1, ColCus).Resize(1, ColCnt)
            End If
        Case "BAD"
            If Not objDicBAD.exists(sKey) Then
                objDicBAD(sKey) = ""
            End If
        End Select
    Next i
    ' Loop through cust.
    For Each sKey In objDicRR.Keys
        If Not objDicBAD.exists(sKey) Then
            If rngHL Is Nothing Then
                Set rngHL = objDicRR(sKey)
            Else
                Set rngHL = Application.Union(rngHL, objDicRR(sKey))
            End If
        End If
    Next
    ' Highlight cust.
    rngData.Interior.Color = xlNone
    If Not rngHL Is Nothing Then
        rngHL.Interior.Color = RGB(200, 205, 5)
    End If
End Sub