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:
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
Dictionary
objects to track the Provision
of customersMicrosoft documentation:
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 objDicRR.exists(sKey) Then
Set objDicRR(sKey) = Application.Union(objDicRR(sKey), rngData.Rows(i))
Else
Set objDicRR(sKey) = rngData.Rows(i)
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