Conditionally formatting a looped range of cells based on value in other cell in VBA

Question

I am trying to conditionally format a range of cells based on the number in the column to each cell groupings' left. Basically, if in row 13, the gray column to the left of each cell grouping = 0, then I want the whole cell grouping to its right to turn green, if = 15, turn yellow, if = 25 turn red. Row 12 is what is happening with my code right now and row 13 is what I want it to look like. I can't seem to get the loop correct.

Sub Highlight3()

   For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row

     If Cells(i, 4) = "Highlight" Then
        For j = 1 To 15

     Range(Cells(i, j * 4 + 2), Cells(i + 1, j * 4 + 4)).Select

        Selection.FormatConditions.Delete
        Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23 = 0"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
          With Selection.FormatConditions(1).Interior
           .Color = rgbRed
         End With

        Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23= 15"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
          With Selection.FormatConditions(1).Interior
           .Color = rgbGold
          End With

        Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23 = 25"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
          With Selection.FormatConditions(1).Interior
           .Color = rgbGreen
          End With


       Next j
      End If
  Next i
End Sub

Answer 1

Avoid Select because it's slow and unyieldy. Just directly assign your Ranges to variables and work with those.

Sub Highlight3()

    For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row Step 2

        If Cells(i, 4) = "Highlight" Then
            For j = 1 To 15

            Dim r As Range
            Set r = Range(Cells(i, j * 4 + 2), Cells(i + 1, j * 4 + 4))

            Dim checkAddress As String
            checkAddress = Cells(i, j * 4 + 1).Address

            With r.FormatConditions
                .Delete

                .Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 0"
                .Item(.Count).Interior.Color = rgbRed

                .Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 15"
                .Item(.Count).Interior.Color = rgbGold

                .Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 25"
                .Item(.Count).Interior.Color = rgbGreen
            End With

            Next j
        End If
    Next i
End Sub

Things to notice:

• No more ugly use of selection - get the Range r once and do all the tasks with its conditional formatting in one clean block.

• No longer sets the new conditional formats to have first priority. Edit that back in if necessary, but I was guessing that it was just something that the Macro Recorder did.

• Builds the formatting formula to check against the address directly left of the first cell. Make sure that the expression for checkAddress is what you'd expect, because I had to infer it from your picture and code. If that area with the value 0/15/25 is actually two merged cells (kinda looks like it is), then make sure this formula is for the upper cell, because that cell will be the one that actually holds the value.

• Again, hard to tell from just a picture, but it looks like each of your "rows" is actually two cells high (based on your code, too). So you actually want to step through values of i by 2 at a time, not 1 at a time.

If any of the assumptions I've just listed about your table's formatting are wrong, let me know and I'll help iron out any remain kinks in the code.

Answer 2

This should do what you want and also be a bit faster:

Sub Highlight3()

  Dim i As Long, j As Byte, myCols As Range, myRng As Range

  Set myCols = Range("$B:$D")

  For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
    If Cells(i, 4) = "Highlight" Then

      If myRng Is Nothing Then
        Set myRng = Intersect(Rows(i), myCols)
      Else
        Set myRng = Union(myRng, Intersect(Rows(i), myCols))
      End If

      i = i + 1 'skip the line after, because it will never have a value / merged cell

    End If
  Next

  If myRng Is Nothing Then Exit Sub

  For i = 4 To 60 Step 4
    For j = 0 To 1
      With myRng.Offset(j, i)

        .Cells(1).Offset(-j).Activate
        .FormatConditions.Delete 'if that does not interfer with other stuff, better use the next line
        'If j = 0 Then myCols.Offset(, i).FormatConditions.Delete

        .FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=0"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Color = rgbRed

        .FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=15"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Color = rgbGold

        .FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=25"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Color = rgbGreen

      End With
    Next
  Next

End Sub

tested it locally and it worked... there may be issues which I can not know (better test it with a copy of your workbook).

The first part pushes all lines in a range which is used in the second part. This way, each pack of columns needs only 2 steps (no need to run EVERY line).

If you have any questions or problems with this code, just ask ;)