Conditional highlighting: How to optimise? - excel

Question

I have code which achieves exactly what I want. The basis of my code comes from the generous help of Tim Williams in a previous question. Building on his help, I have added slightly to the functionality (larger font size, and returning formatting to original if nothing in the column is selected), and extended the code across several columns, as shown in the code.
The problem is my spreadsheet is now intolerably slow. Is there a way to speed things up?
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

Darren Bartrup is right. Code Review is an excellent site to obtain help on making your code more efficient.
I'm providing an answer as I'm not sure you've quite got the spirit of Tim Williams' answer. As well as not needing to iterate the cells, you should also be able to do without identical code for each tested column. You can do this by creating some form of selected column to highlight column map. Below is skeleton code to get you started.
The code you've supplied shouldn't be as slow as you are describing, so I wonder if you're handling other events (or there's more code in your _Select event). If there is, then make sure you include it in your question on Code Review or here.
Option Explicit
Private mColumnMap As Collection
Private mOldRange As Range
Private mOldCellColour As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim mappedRange As Range
Dim mappedCells As Range
'Define the column map.
If mColumnMap Is Nothing Then
Set mColumnMap = New Collection
mColumnMap.Add Me.Range("H:I"), "14" 'N
mColumnMap.Add Me.Range("J:J"), "15" 'O
mColumnMap.Add Me.Range("K:K"), "16" 'P
mColumnMap.Add Me.Range("L:L"), "17" 'Q
End If
'If there is a highlighted range, change it back.
If Not mOldRange Is Nothing Then
With mOldRange
.Interior.Color = mOldCellColour
.Font.Bold = False
End With
Set mOldRange = Nothing
End If
'Ignore any selections that are more than one column.
If Target.Columns.Count <> 1 Then Exit Sub
'Ignore any selections outside of a specified range.
'Note: I've just used the 'UsedRange'.
If Intersect(Target, Me.UsedRange) Is Nothing Then Exit Sub
'Acquire the appropriate column map.
On Error Resume Next
Set mappedRange = mColumnMap(CStr(Target.Column))
On Error GoTo 0
'Exit if not a target column.
If mappedRange Is Nothing Then Exit Sub
'Define the cells to be changed.
Set mappedCells = Intersect(mappedRange, Target.EntireRow)
'Store the original values.
Set mOldRange = mappedCells
mOldCellColour = mappedCells(1).Interior.Color
'Change the values.
Application.ScreenUpdating = False
With mappedCells
.Interior.Color = vbWhite
.Font.Bold = True
End With
Application.ScreenUpdating = True
End Sub