VBA Highlight consequent cells based on value from another cell with criteria

[Anita89]

Hello together,

please help me to extend my VBA code to highlight amount of cells (top to bottom) for a certain year based on how many tools are planned in separate table on the right side in attached "example".
So far i wrote code that only counts tools for first country, but i dont know how to bind it to value from another table.

For example in USA it is planned to have 2 cutting tools in 2023 so for 2 cutting tools must be highlighted 2 cells in col. C
thank you in advance, i am totally new to vba.

Dim rng1, rng2 As Range
    Dim criteria1, criteria2 As Variant
    Dim result As Double
 
    Set rng1 = Range("A2:A14")
    criteria1 = "USA"
 
    Set rng2 = Range("B2:B14")
    criteria2 = "Cutting tool"
 
    result = WorksheetFunction.CountIfs(rng1, "*" & criteria1 & "*", rng2, "*" & criteria2 & "*")

DEVELOPER.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	Country	Category	2023	2024	2025	2026	2027						2023	2024	2025	2026	2027
2	USA	Cutting tool									USA	Cutting tool	2	3	2	4	5
3	USA	Cutting tool									Europe	Cutting tool	1	3	2	2	1
4	USA	Cutting tool
5	USA	Cutting tool
6	USA	Cutting tool
7	USA	Cutting tool
8	Europe	Cutting tool
9	Europe	Cutting tool
10	Europe	Cutting tool
11	Europe	Cutting tool
12	Europe	Cutting tool
13	Europe	Cutting tool
14	Europe	Cutting tool
15
16
Sheet3

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
M1:Q1	Cell	contains a blank value	text	NO
C1:G1	Cell	contains a blank value	text	NO

 

[Herakles]

Why don't you just have a chart?

Lots of different ones to choose from.

So east to set up.

 

[Anita89]

Why don't you just have a chart?

Lots of different ones to choose from.

So east to set up.

I dont need chart. i need table. i will add text in non-highlighted cells

 

[Herakles]

Give this a try.

It allows 3 rows under each location until the next location but this can be changed.

It takes a while to run but confirms when it is complete.

Public Sub subConditionalFormatting()
Dim rngGrid As Range
Dim rngColumn As Range
Dim rng As Range
Dim rngValues As Range
Dim i As Integer
Dim rngLocation As Range
Dim intCol As Integer
Dim strMsg As String

    Range("A2:B20").ClearContents
    
    Set rngValues = Range("M2:Q3")
    
    ActiveWorkbook.Save

    Set rngGrid = Range("$C$2:$G$" & WorksheetFunction.Max(rngValues) + 3)
    
    strMsg = "Conditional Formatting complete for : " & vbCrLf & vbCrLf
    
    For Each rngLocation In rngValues.Rows
        
        intCol = 1
        
        For Each rngColumn In rngGrid.Columns
        
            i = 1
            
            For Each rng In rngColumn.Cells
            
                Cells(rng.Row, 1).Resize(1, 2).Value = rngLocation.Offset(0, -2).Resize(1, 2).Value
                
                rng.FormatConditions.Delete
                
                rng.FormatConditions.Add Type:=xlExpression, Formula1:="=" & rngLocation.Cells(intCol).Address & ">=" & i
                
                rng.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
          
                i = i + 1
                
            Next rng
          
            intCol = intCol + 1
            
        Next rngColumn
        
        strMsg = strMsg & rngGrid.Cells(1).Offset(0, -2).Value & " " & rngGrid.Cells(1).Offset(0, -1).Value & vbCrLf
      
        Set rngGrid = rngGrid.Offset(rngGrid.Rows.Count, 0).Resize(WorksheetFunction.Max(rngLocation.Offset(1, 0)) + 3, rngGrid.Columns.Count)
      
        Next rngLocation
        
        strMsg = strMsg
        
        MsgBox strMsg, vbInformation, "Confirmation"
    
End Sub

 

[Anita89]

thank you, it works, many many thanks

 

[Herakles]

I'm glad that it did the job for you.

Can you please mark it as a solution? (Tick in circle on the right.)