Conditional highlighting (Font size colour, size and Bold) using VBA

Question

Note: Question originally asked in SO.

Objective of Code

In my worksheet I have several columns that need to be compared to other columns. None of these column pairs are contiguous, so it can be difficult to immediately see the correct column a cell should be compared to.

To solve this, I have created VBA code that highlights the relevant cell in the relevant column for comparison. So for example, if I click on cell O5, cell J5 will be highlighted. When I click away, J5 returns to its original format.

By highlight, I mean specifically the cell text becomes white, bigger and is emboldened.

Problem

The code below achieves exactly all this. (Note, the basis of my code comes from the generous help of Tim Williams in a previous question).

The problem is my spreadsheet is now intolerably slow. Note, the WS is quite large, with ~1000 rows X 82 columns.

Is there a way to speed things up?

EDIT

I have three additional Private Subs at the top of my code. Not sure that's relevant, but it was suggested that I inlcude everything.

Private Sub CommandButton1_Click()
Range("U5:U961").Value = Range("T5:T961").Value
End Sub

Private Sub CommandButton2_Click()
Range("W5:W961").Value = Range("V5:V961").Value
End Sub

Private Sub CommandButton3_Click()
Range("Y5:Y961").Value = Range("X5:X961").Value
End Sub

The code of interest starts from here.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r As Range, c As Range
    
    'Set target for all columns that have this functionality
    Set r = Intersect(Me.Range("N:Q"), Target)
    
    'The functionality is repeated for several columns and is identical each time (except for N which maps to two columns)
    
    'Column N maps to columns H & I
    If Not Application.Intersect(Target, Range("N:N")) Is Nothing Then
    
    If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub

    Application.ScreenUpdating = False
        HighlightIt Application.Intersect(Me.Range("H:I"), Me.UsedRange), False
        For Each c In r.Cells
            HighlightIt Me.Cells(c.Row, "H").Resize(1, 2)
        Next c
        
    Else
         With Application.Intersect(Me.Range("H:I"), Me.UsedRange)
            .Font.Bold = False
            .Font.Color = vbBlack
            .Font.Size = 14
            
          End With
    End If
    
    'Column O maps to columns J
     If Not Application.Intersect(Target, Range("O:O")) Is Nothing Then
    
    If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub

    Application.ScreenUpdating = False
        HighlightIt Application.Intersect(Me.Range("J:J"), Me.UsedRange), False
        For Each c In r.Cells
            HighlightIt Me.Cells(c.Row, "J")
        Next c
   
   
    Else
         With Application.Intersect(Me.Range("J:J"), Me.UsedRange)
            .Font.Bold = False
            .Font.Color = vbBlack
            .Font.Size = 14
            
          End With
    End If
    
    
   'Column P maps to columns K
    If Not Application.Intersect(Target, Range("P:P")) Is Nothing Then
    
    If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub

    Application.ScreenUpdating = False
        HighlightIt Application.Intersect(Me.Range("K:K"), Me.UsedRange), False
        For Each c In r.Cells
            HighlightIt Me.Cells(c.Row, "K")
        Next c
   
    Else
         With Application.Intersect(Me.Range("K:K"), Me.UsedRange)
            .Font.Bold = False
            .Font.Color = vbBlack
            .Font.Size = 14
            
          End With
    End If
    
    'Column Q maps to columns L
    If Not Application.Intersect(Target, Range("Q:Q")) Is Nothing Then
    
    If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub

    Application.ScreenUpdating = False
        HighlightIt Application.Intersect(Me.Range("L:L"), Me.UsedRange), False
        For Each c In r.Cells
            HighlightIt Me.Cells(c.Row, "L")
        Next c
        
       Else
         With Application.Intersect(Me.Range("L:L"), Me.UsedRange)
            .Font.Bold = False
            .Font.Color = vbBlack
            .Font.Size = 14
            
          End With
    End If
    
End Sub

'utility sub for highlighting/unhighlighting
Sub HighlightIt(rng As Range, Optional hilite As Boolean = True)
    With rng
        .Font.Color = IIf(hilite, vbWhite, vbBlack)
        .Font.Bold = hilite
        .Font.Size = IIf(hilite, 20, 14)
    End With
End Sub

Answer 1

All of this is in a Worksheet's code, right? In general if you have routines that are called by an event, you want to place those in a real module e.g.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Application.Intersect(Target, checkRange) Then Module1.HighLight target
End Sub

I mean, technically, you need that error check to validate the range on worksheet change, and if it's valid then you do some stuff. So logically it would be broken out as well.

Now, this would break every .Me, so you would pass your range as an argument and use the range to get the parent, if needed.

So instead of .UsedRange you would create a routine that takes your target and finds the correct range, and pass that. UsedRange isn't very specific to someone reading the code, you want to try to be explicit in everything you do.

Target.Cells.CountLarge

Are we dealing with a graph? Using CountLarge is strange - is your range bounded by columns or rows? Explicitly check that those aren't exceeded.

---

Naming

Your naming leaves a bit to be desired. Use the variable's name to tell me something about it. r is a range and c is a range? What range? Is it parentRange and targetCell maybe?

Sub HighlightIt(rng As Range, Optional hilite As Boolean = True)

Oh, rng is a range and the other thing is a boolean? If it's a boolean, you can make it look like a boolean. isHighlighted or something similar. If I read through your HighlightIt routine, everytime I see hilite as a true/false test - what is being evaluated? What if you pass False?

HighlightIt Application.Intersect(Me.Range("K:K"), Me.UsedRange), False

Well, it seems like a different highlighting will take place. I'd break those out into two different functions and do the check and call one or the other

Also, you haven't passed those parameters ByVal which means they are passed ByRef implicitly. If you want them ByRef, do it explicitly. If there's no good reason you need it ByRef then pass them ByVal

 Private Sub HighlightTargetRange(ByVal target as Range)

So now there's a total of 3 variables? For all this code? Hmph

You also check some columns for intersect. I'd use some constants to identify the columns and make it more clear what your checking, for instance if column K is to check a conditions then

 Const COLUMN_CONDITION_CHECK as Long = 11

Refactor

You have this (roughly) four times -

     With Application.Intersect(Me.Range("K:K"), Me.UsedRange)
        .Font.Bold = False
        .Font.Color = vbBlack
        .Font.Size = 14

      End With

You just pass a different range. That's screaming to be refactoring into a method which can then be called from each of the three locations, rather than repeating it.

Private Sub DefaultFormat(ByVal targetRange As Range)
    targetRange.Font.Bold = False
    targetRange.Font.Color = RGB(0, 0, 0)
    targetRange.Font.Size = 14
End Sub

A lot cleaner. Oh, yeah, use RGB when you can. Sometimes the color constants can get weird and might cause issues on different systems. Instead, use the RGB() method. I know that's talking about ColorIndex but the point still stands.

But wait! It looks like you have the same thing 4 times with just different intersect ranges! Even better!

Also- your indentation levels are all messed up. Maybe that's a result of a copy/paste, but you should always make sure those levels are clear.

---

So now your sheet code is

Private Sub Worksheet_SelectionChange(ByVal target As Range)
    If Not Application.Intersect(Me.Range("N:Q"), target) Is Nothing Then
        Module1.BeginFormat target
    End Sub
End Sub

And your main code would be like

Option Explicit
Private Sub BeginFormat(ByVal target As Range)
Application.ScreenUpdating = False
    Dim masterRange As Range
    Set masterRange = Application.Intersect(Sheet1.Range("N:Q", target))
    Dim originRange As Range
    Set originRange = Sheet1.UsedRange
    Dim targetCell As Range
    Dim index As Long
    Dim lastRow As Long
    lastRow = masterRange.Cells(Rows.Count, 8).End(xlUp).Row
    If masterRange Is Nothing Or target.Cells.CountLarge > 960 Then GoTo CleanExit
        For columns N, O, J, K, Q, L
            CheckHighlight target, targetColumn
        Next
    End If

CleanExit:
    Application.ScreenUpdating = True
End Sub
Private Sub CheckHighlight(ByVal target As Range, ByVal targetColumn As Range)
    'check intersect
    'create range
    DefaultFormat Range
    If something Then
        BoldHighlight Range
    Else
        SecondaryHighlight Range
    End If
End Sub

Private Sub DefaultFormat(ByVal targetRange As Range)
    targetRange.Font.Bold = False
    targetRange.Font.Color = RGB(0, 0, 0)
    targetRange.Font.Size = 14
End Sub

Answer 2

There is a lot of repeat code that could be refactored out but the OP's concern is performance. The reason that the code is so slow is that it is unnecessarily looping over the cells of the range to be highlighted. Formats can and should be applied in to the entire range at once.

  HighlightIt Application.Intersect(Me.Range("H:I"), Me.UsedRange), False

Unlike working with values, it is more efficient to apply formatting to entire rows and columns then it is to the cells UsedRange.

  HighlightIt Columns("H:I"), False

Excel data and metadata is stored as xml inside that Excel document which is actually a zip file. Applying formatting to entire rows and columns creates css rules that will be applied to all the cells of the rows and columns. Formatting blocks of cells causes Excel to create a node for each cell.

To demonstrate this I created a workbook with 2 worksheets that only had a single value in A1. Sheet1 had columns A:J formatted, whereas Sheet2 had Range("A1:J100") formatted. I then change the file extension to .zip and extracted all the files.

Notice that although sheet2 is 12 times larger than sheet1.

Sheet1 XML

Sheet2 XML

Refactored Code

Private Sub Worksheet_SelectionChange(ByVal target As Range)
    Application.ScreenUpdating = False

    Dim r As Range
    'Set target for all columns that have this functionality
    Set r = Intersect(Columns("H:L"), target)
    If Not r Is Nothing Then HighlightIt Columns("H:L"), False

    'Column N maps to columns H & I
    Set r = Application.Intersect(target, Columns("N"))
    If Not r Is Nothing Then
        HighlightIt r.Offset(ColumnOffset:=-6)
        HighlightIt r.Offset(ColumnOffset:=-5)
    End If

    'Column O:Q maps to columns J:L
    Set r = Application.Intersect(target, Columns("O:Q"))
    If Not r Is Nothing Then HighlightIt r.Offset(ColumnOffset:=-5)

    Application.ScreenUpdating = True
End Sub

'utility sub for highlighting/unhighlighting
Sub HighlightIt(rng As Range, Optional hilite As Boolean = True)
    If rng Is Nothing Then Exit Sub
    With rng
        .Font.Color = IIf(hilite, vbWhite, vbBlack)
        .Font.Bold = hilite
        .Font.Size = IIf(hilite, 20, 14)
    End With
End Sub

Create Mock Data

Sub Prep()
    Dim cell As Range
    Application.ScreenUpdating = False
    For Each cell In Range("A1").Resize(20000, 82)
        cell.Value = cell.Address(0, 0)
    Next
    Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

Demo

Real time example using 20000 rows X 82 columns on a slow computer.