Conditional formatting using VBA macros

Conditional formatting in Excel is a smart way to highligt cells that meet certain criteria, e.g. values above a certain limit.

However counting the cells afterwards is very difficult, unless you do it manually, so in some cases it can be better to use VBA macros instead.

A colleague of mine has a spreadsheet with quality and process data on a daily basis, 24 rows and X columns for each day. He used Excel's conditional formatting to paint the cells red if so and so.

The other day he asked, if I could write a macro that counted the red cells in each column. Ignorantly I said: "Yes, of course" and thought it would be an easy job. I was wrong!

It is very complicated (if possible), and it turned out to be a lot easier to put his conditions into a macro and let VBA do the formatting.

There is an example below, and you can download a zip compressed workbook with a table and the code here.

It then loops through the columns, and if a cell value is below or above a limit, it gets a red background colour.

If you leave a limit cell empty, the limit will be ignored (not tested). That gives 4 scenarios to test:

Also, if you define a column with control values (here: runtime), outliers will be ignored if the check value isn't = 1.

If you expand the table to the right, the macro will find out and include new columns.

You can select the code below with the mouse, copy it (CTRL+C) and paste it into a VBA module (CTRL+V) or download the zip compressed Excel workbook with the example.

The code uses ranges and nested For Each Next loops, and there is also a test to check if a value is a whole number (Integer) or not.

Nothing stops you from adding an optional LowLow and HighHigh limit, but then the number of scenarios to test will increase from 4 to 16.

Sub FormatCells()
Dim bL As Boolean       'True if a low limit is defined
Dim bH As Boolean       'True if a high limit is defined
Dim bRed As Boolean     'True if to be coloured red
Dim bCheck As Boolean   'True if check column is active
Dim lCols As Long       'Number of columns
Dim lActiveCol As Long  'Present column
Dim lOffset As Long     'Variable for column offset
Dim lRedCount As Long   'Counter for red cells
Dim dHigh As Double     'High limit
Dim dLow As Double      'Low limit
Dim rMode As Range      'Row for CF or check cells - here row 26
Dim rCol As Range       'Column with cells to be formatted
Dim rMCell As Range     'Range variable for looping through cells
Dim rCell As Range      'Range variable for looping through columns

On Error GoTo ErrorHandle

'Switch off screen updating for speed
Application.ScreenUpdating = False

'Define the table to get the number of columns. For this
'example to work, the table must begin in cell A1.
Set rMode = Range("A1").CurrentRegion

'The number of columns minus column A with the hours
lCols = rMode.Columns.Count - 1

'Now we define rMode as the row (26) with cells
'that tell us if it is a check column or a
'column with cells that must be formatted conditionally
Set rMode = Range(Range("B26"), Range("B26").Offset(0, lCols - 1))

'We now loop through the row, rMode,to find out, if the
'column is to be formatted conditionally. If not, we skip it
'and move to the next column.
For Each rMCell In rMode
   'Increment column number
   lActiveCol = lActiveCol + 1
   
   With rMCell
      'If it is a column with cells that can be
      'formatted conditionally
      If .Value = "CF" Then
         
         'Reset variables
         bCheck = False
         lRedCount = 0
         
         'Is there is a check column with e.g. runtime?
         If IsNumeric(.Offset(1, 0).Value) And .Offset(1, 0).Value <> 0 Then
            'The offset value as a Long (or Integer)
            lOffset = CLng(.Offset(1, 0).Value)
            'Check if it is an Integer or Long. If it is a double
            'it will trigger an error.
            If Abs(.Offset(1, 0).Value / lOffset) = 1 Then
               'Is it within the table?
               If lOffset > 0 And lOffset + lActiveCol <= lCols Then
                  bCheck = True
               ElseIf lOffset < 0 And lActiveCol + lOffset > 0 Then
                  bCheck = True
               Else
                  MsgBox "The column for check values is not " & _
                  "in the table. Check your offset value in cell " & .Address
               End If
            Else
               MsgBox "Column offset must be a whole number." & _
               .Offset(1, 0).Value & " is ignored."
            End If
         End If
                 
         'Check low limit
         If IsEmpty(.Offset(3, 0)) = False And _
         IsNumeric(.Offset(3, 0).Value) Then
            dLow = .Offset(3, 0).Value
            bL = True
         Else
            bL = False
         End If
         
         'Check high limit
         If IsEmpty(.Offset(4, 0)) = False And _
         IsNumeric(.Offset(4, 0).Value) Then
            dHigh = .Offset(4, 0).Value
            bH = True
         Else
            bH = False
         End If
         
         'If neither low nor high limit there is
         'no condition and we skip the column.
         If bL = False And bH = False Then GoTo Skip
         
         'We are now ready to loop through the cells and check
         'if they should be formatted conditionally
         Set rCol = Range(.Offset(-1, 0), .Offset(-24, 0))
         
         'There are 3 scenarios with low and high limit. There
         'are actually 4, but we have already checked for
         'bL = False and bH = False
         'Scenario 1:
         If bL And bH Then
            For Each rCell In rCol
               bRed = False 'Reset flag
               With rCell
                  'If the value is lower or higher than
                  'the limit, it gets a red background colour.
                  If .Value < dLow Or .Value > dHigh Then
                     If bCheck And .Offset(0, lOffset).Value = 1 Then
                        bRed = True
                     ElseIf bCheck = False Then bRed = True
                     End If
                  End If
                  If bRed Then
                     .Interior.ColorIndex = 3
                     .Interior.Pattern = xlSolid
                     lRedCount = lRedCount + 1
                  Else
                     'No colour
                     .Interior.ColorIndex = xlNone
                  End If
               End With
            Next
         End If
         
         'Scenario 2:
         If bL And bH = False Then
            For Each rCell In rCol
               bRed = False
               With rCell
                  If .Value < dLow Then
                     If bCheck And .Offset(0, lOffset).Value = 1 Then
                        bRed = True
                     ElseIf bCheck = False Then bRed = True
                     End If
                  End If
                  If bRed Then
                     .Interior.ColorIndex = 3
                     .Interior.Pattern = xlSolid
                     lRedCount = lRedCount + 1
                  Else
                     .Interior.ColorIndex = xlNone
                  End If
               End With
            Next
         End If
         
         'Scenario 3:
         If bL = False And bH Then
            For Each rCell In rCol
               bRed = False
               With rCell
                  If .Value > dHigh Then
                     If bCheck And .Offset(0, lOffset).Value = 1 Then
                        bRed = True
                     ElseIf bCheck = False Then bRed = True
                     End If
                  End If
                  If bRed Then
                     .Interior.ColorIndex = 3
                     .Interior.Pattern = xlSolid
                     lRedCount = lRedCount + 1
                  Else
                     .Interior.ColorIndex = xlNone
                  End If
               End With
            Next
         End If
      Else
         GoTo Skip
      End If
      .Offset(2, 0).Value = lRedCount
   End With
Skip:
Next

BeforeExit:
Set rMode = Nothing
Set rCol = Nothing
Set rMCell = Nothing
Set rCell = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure FormatCells"
Resume BeforeExit
End Sub

That's it - a way of using VBA for conditional formatting and counting cells that are formatted conditionally.