Excel VBA color cell based on value in two other cells-CodePudding

I am trying to fill cells in a range with color based on the values of two other cells.

I work with the table below:

I want to color cells where Type = "B" and Helper1 = 1 or where Type = "C" and Helper 2 = 1.

Desired result:

I was able to achieve this using conditional formatting, however because I cannot copy the cond formatting to other workbooks (due to missing helper rows), I need to do it in VBA.

Can anyone point me into the right direction here?

Thanks a lot!

CodePudding user response：

Just loop trough each cell and check if first column equals B or C and if row 1 or 2 of data equals to 1

Application.ScreenUpdating = False
Dim rng As Range

For Each rng In Range("A1").CurrentRegion
    If rng.Column = 1 Or rng.Row = 1 Or rng.Row = 2 Then
        'do nothing, headers and first column
    Else
        If Cells(rng.Row, 1) = "B" And Cells(1, rng.Column) = 1 Then rng.Interior.Color = vbYellow 'if first column=B and Helper1=1
        If Cells(rng.Row, 1) = "C" And Cells(2, rng.Column) = 1 Then rng.Interior.Color = vbYellow 'if first column=B and Helper2=1
    End If
Next rng
Application.ScreenUpdating = True

Notice Column H got no yellow color because Helper1 and Helper2 are both zeros (I did that for testing purposes)

CodePudding user response：

Even if you received an answer, please test the next way, too. It should be a little faster:

Sub colorRangesConditionally()
   Dim sh As Worksheet, lastR As Long, arr, rngH1 As Range, rngH2 As Range, i As Long
   
   Set sh = ActiveSheet
   lastR = sh.Range("A" & sh.rows.count).End(xlUp).Row
   
   arr = sh.Range("A1:M" & lastR).Value2 'place the range in an array for faster iteration
   sh.Range("A3:M" & lastR).ClearFormats 'clear format of the previous runs
   
   For i = 2 To 13
        If arr(1, i) = 1 Then addToRange rngH1, sh.cells(1, i)
        If arr(2, i) = 1 Then addToRange rngH2, sh.cells(2, i)
   Next i
   Set rngH1 = rngH1.EntireColumn
   Set rngH2 = rngH2.EntireColumn
   
   Application.ScreenUpdating = False
   For i = 3 To UBound(arr)
        If arr(i, 1) = "B" And Not Intersect(rows(i), rngH1) Is Nothing Then
            Intersect(rows(i), rngH1).Interior.Color = vbYellow
        End If
        If arr(i, 1) = "C" And Not Intersect(rows(i), rngH2) Is Nothing Then
            Intersect(rows(i), rngH2).Interior.Color = vbYellow
        End If
   Next i
   Application.ScreenUpdating = True
End Sub

Sub addToRange(rngU As Range, rng As Range)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub