EN VI

Excel - How to identify String verities over known categories by Scripting dictionary?

I have a table that I need to add a restrict role to highlight the rows that contain a specific string type and release any rows that return with string verities.

the roles that I want to achieve are:

If all the rows under the same customer number are provisioned as "Bad" then this is OK.
If all the rows under the same customer number are mixed between "RR" & "Bad" then this is ok.
If all the rows under the same customer number are provisioned as "RR" then highlight these rows.

with excluding the rows that have Category "XO" and provisioned as "Exc" from the role

My table :

Customer Number	Customer Name	Invoice	Provision	Category
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	DEF	124592	Bad	XO
32336	DEF	124593	Bad	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	Bad	XX
13914	JKL	124600	RR	XX

The code I have so far highlights if the rows provisioned as "RR" (which is needed) but still doesn't ignore the customer number that has a "Bad" row among the "RR" rows. your help is much appreciated and Please let me know if you need more clarification.

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

Solution:

Use two Dictionary objects to track the Provision of customers

Microsoft documentation:

Range.Resize property (Excel)

Application.Union method (Excel)

Option Explicit

Sub Demo()
    Dim oDicBAD As Object, oDicRR As Object
    Dim i As Long, sKey As Variant, ColCnt As Long
    Dim arrData, oTab As ListObject, rngHL As Range, rngData As Range
    Dim ColCus As Long, ColPro As Long, ColCat As Long
    Set oTab = ActiveSheet.ListObjects(1)
    With oTab
        Set rngData = .DataBodyRange
        ColCus = .ListColumns("Customer Number").Index
        ColPro = .ListColumns("Provision").Index
        ColCat = .ListColumns("Category").Index
        ColCnt = .ListColumns.Count
    End With
    ' Load table into array
    arrData = rngData.Value
    Set oDicBAD = CreateObject("scripting.dictionary")
    Set oDicRR = 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 oDicRR.exists(sKey) Then
                Set oDicRR(sKey) = Application.Union(oDicRR(sKey), rngData.Cells(i, ColCus).Resize(1, ColCnt))
            Else
                Set oDicRR(sKey) = rngData.Cells(i, ColCus).Resize(1, ColCnt)
            End If
        Case "BAD"
            If Not oDicBAD.exists(sKey) Then
                oDicBAD(sKey) = ""
            End If
        End Select
    Next i
    ' Loop through cust.
    For Each sKey In oDicRR.Keys
        If Not oDicBAD.exists(sKey) Then
            If rngHL Is Nothing Then
                Set rngHL = oDicRR(sKey)
            Else
                Set rngHL = Application.Union(rngHL, oDicRR(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