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

• Graipher: Hey, welcome to Code Review! Could you edit in a bit more information about what it means that "[this] achieves exactly what I want"? As it is currently written, it is unclear what problem your code actually solves.
• SeánMcK: Sure! I'll make the changes now.
• SeánMcK: Answer given in SO. stackoverflow.com/q/51893295/6065710 Should I delete the question here?
• Graipher: You can leave it here, if you want to. Code Review questions seldomly have the one true answer. Maybe you get some additional comments and learn something new from another answer here.

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

• PeterT: For the Sheet1.Range("N:Q") area, I will typically create a named range either in VBA or a manual definition. This way I can easily change the range of interest without changing much/any code. A question I have for you though is the If masterRange Is Nothing... Then GoTo... statement. You've indented the For below that and added an End If. I'm not next to my handy VBA compiler, but do you need the End If at all? My thinking is the If ... Then ... Goto is a complete statement all by itself.
• Raystafarian: If Then in one line doesn't need end if, so yes

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.

enter image description here

Notice that although sheet2 is 12 times larger than sheet1.

Sheet1 XML

enter image description here

Sheet2 XML

enter image description here

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

enter image description here

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