Recoloring cells to create a heat map dynamic legend

Goal: Get the code to execute quicker

Quick Overview of the codes objective:

Takes the colors of a heatmap created in excel and changes them whenever a target cell is changed on the input worksheet(something that would change the heatmap). The heat map is created to show which of many pensions plans will be the highest value at any given time, and utilizes excels condition formats to decide which color to output. The code then formats the output year cell in black bold to make it easier to see and creates a dynamic legend to make the viewer undertand which colors link to which pension plan.

The code below has 2 major parts which I will outline. Please see the numbered parts 1, 2 for more info on each portion.

1.) This portion of the code is setting up an array of variables withing Cond that are set to various color codes on the worksheet to allow people to change the heat map page colors. It is also setting up legend variables to allow the dynamic legend to work.

2.) This Portion of the code is using for statements within with statements to loop through all 17 .formatconditions and change the color to equal the value selected on the input sheet by the user by simply changing the color of a cell. It also changes the text to the same color so that the heat map shows all one color as the color is dependent on the text in the cell, but the desired output is simply a colored cell with appearingly no text. It moves on to change the legend using an autofiltered table so that the camera function of excel can capture a dynamic legend by taking a picture of the auto filtered table.

'1) --------------------------------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)

'Do nothing if more than one cell is changed or content deleted

If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub

If Not Intersect(Target, Range("c9:c42,B5:B6,e6")) Is Nothing Then

'Stop any possible runtime errors and halting code

On Error Resume Next

'Turn off ALL events

Application.EnableEvents = False
Application.ScreenUpdating = False

Dim Cfr As Long
Dim Cond(2 To 17) As Long
Cond(2) = Sheet1.Range("o7").Value
Cond(3) = Sheet1.Range("o10").Value
Cond(4) = Sheet1.Range("o13").Value
Cond(5) = Sheet1.Range("o15").Value
Cond(6) = Sheet1.Range("o17").Value
Cond(7) = Sheet1.Range("o19").Value
Cond(8) = Sheet1.Range("o21").Value
Cond(9) = Sheet1.Range("o23").Value
Cond(10) = Sheet1.Range("o25").Value
Cond(11) = Sheet1.Range("o27").Value
Cond(12) = Sheet1.Range("o29").Value
Cond(13) = Sheet1.Range("o31").Value
Cond(14) = Sheet1.Range("o34").Value
Cond(15) = Sheet1.Range("o37").Value
Cond(16) = Sheet1.Range("o39").Value
Cond(17) = Sheet1.Range("o41").Value
Dim Legend(2 To 17) As Range
Set Legend(2) = Sheet26.Range("a2")
Set Legend(3) = Sheet26.Range("a5")
Set Legend(4) = Sheet26.Range("a8")
Set Legend(5) = Sheet26.Range("a10")
Set Legend(6) = Sheet26.Range("a12")
Set Legend(7) = Sheet26.Range("a14")
Set Legend(8) = Sheet26.Range("a16")
Set Legend(9) = Sheet26.Range("a18")
Set Legend(10) = Sheet26.Range("a20")
Set Legend(11) = Sheet26.Range("a22")
Set Legend(12) = Sheet26.Range("a24")
Set Legend(13) = Sheet26.Range("a26")
Set Legend(14) = Sheet26.Range("a29")
Set Legend(15) = Sheet26.Range("a32")
Set Legend(16) = Sheet26.Range("a34")
Set Legend(17) = Sheet26.Range("a36")

'2) --------------------------------------------------------------------

With Sheet18.Cells
For Cfr = 2 To 17
With .FormatConditions(Cfr).Interior
.Color = Cond(Cfr)
End With
Next Cfr
End With
With Sheet18.Cells
For Cfr = 2 To 17
With .FormatConditions(Cfr).Font
.Color = Cond(Cfr)
End With
Next Cfr
End With
With Sheet26
For Cfr = 2 To 17
With Legend(Cfr)
.Interior.Color = RGB(Cond(Cfr) Mod 256, Cond(Cfr) \ 256 Mod 256, Cond(Cfr) \ 65536 Mod 256)
End With
Next Cfr
End With
Dim Rng As Range
Set Rng = Sheet18.Range("c1:bc53")
With Rng.Borders
.LineStyle = xlNone
End With
Dim Tcell As Range
Set Tcell = Sheet18.Range("b54").Offset(Sheet1.Range("a59"), Sheet1.Range("a58"))

With Tcell.Borders
.LineStyle = xlContinuous
.Weight = xlThick
.Color = vbBlack
End With
With Sheet26
.AutoFilterMode = False
.Range("A1:j42").AutoFilter
.Range("A1:j42").AutoFilter Field:=10, Criteria1:="<=8", _
Operator:=xlAnd, Criteria2:=">=1"
End With

'Turn events back on

Application.EnableEvents = True
Application.ScreenUpdating = True

'Allow run time errors again

On Error GoTo 0

End If

End Sub


This code causes excel to be unresponsive for around 5-6 seconds if not longer. Is there something I'm doing that is horribly inefficient? I've tried turning application.calculation to manual and it does not make a difference.

Computer Specs

• i7-6700 3.4gh
• 8 gb ram
• Win 10 pro
• Excel 2016

The changes I would make to the code

• Add Option Explicit at the top of every module - first step in catching syntax errors
• Change Target.Cells.Count to Target.Cells.CountLarge
• .Count is a Long (can throw an error if a large number of cells are pasted)
• .CountLarge is a Variant/LongLong
• Move "magic numbers" to the top for easy maintenance
• "magic numbers" are constants that repeat, and are hard-coded throughout
(one change must be made in multiple places)

Set Tcell = Sheet18.Range("b54").Offset(Sheet1.Range("a59"), Sheet1.Range("a58"))

• I think it would be clearer if you had the actual range Sheet18.Range("A1:Z100")
• but if you need to extract it, you should validate Range("aB54") and Range("a58")
• Combine 4 separate For loops into one
• Keep consistent indentation, at proper levels
• On Error Resume Next should never be used as a "catch all" like in your code
• It doesn't fix all errors - it hides them under the rug (sooner or later it will trip)
• On each line, all errors should be expected (through testing) and be handled

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Const FRST_ID = 2
Const LAST_ID = 17
Const TARGET_RNG = "C9:C42,B5:B6,E6"

Const COL_OFFSET_WS18 = "A58"
Const ROW_OFFSET_WS18 = "A59"
Const CEL_BORDERS_WS18 = "B54"
Const ALL_BORDERS_WS18 = "C1:BC53"

Const FILTER_WS26 = "A1:J42"

Const COND_RNG = "O7 O10 O13 O15 O17 O19 O21 O23 O25 O27 O29 O31 O34 O37 O39 O41"
Const LEGEND_RNG = "A2 A5 A8 A10 A12 A14 A16 A18 A20 A22 A24 A26 A29 A32 A34 A36"

If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub

If Not Intersect(Target, Me.Range(TARGET_RNG)) Is Nothing Then
Dim ws01 As Worksheet:  Set ws01 = Sheet1
Dim ws18 As Worksheet:  Set ws18 = Sheet18
Dim ws26 As Worksheet:  Set ws26 = Sheet26
Dim rOffset18 As Long:  rOffset18 = ws01.Range(ROW_OFFSET_WS18)
Dim cOffset18 As Long:  cOffset18 = ws01.Range(COL_OFFSET_WS18)

If rOffset18 > 0 And cOffset18 > 0 Then
Dim cnd(FRST_ID To LAST_ID) As Long
Dim lgd(FRST_ID To LAST_ID) As Range
Dim arrCnd As Variant:  arrCnd = Split(COND_RNG)
Dim arrLgd As Variant:  arrLgd = Split(LEGEND_RNG)
Dim i As Long, r As Long, g As Long, b As Long

Application.EnableEvents = False
Application.ScreenUpdating = False

For i = FRST_ID To LAST_ID
With ws18.Cells.FormatConditions(i)
.Interior.Color = ws01.Range(arrCnd(i - FRST_ID)).Value2
.Font.Color = ws01.Range(arrCnd(i - FRST_ID)).Value2
End With
r = cnd(i) Mod 256
g = cnd(i) \ 256 Mod 256
b = cnd(i) \ 65536 Mod 256
ws26.Range(arrLgd(i - FRST_ID)).Interior.Color = RGB(r, g, b)
Next i

ws18.Range(ALL_BORDERS_WS18).Borders.LineStyle = xlNone

With ws18.Range(CEL_BORDERS_WS18).Offset(rOffset18, cOffset18).Borders
.LineStyle = xlContinuous
.Weight = xlThick
.Color = vbBlack
End With
ws26.Range(FILTER_WS26).AutoFilter Field:=10, Criteria1:="<=8", _
Operator:=xlAnd, Criteria2:=">=1"
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End If
End Sub


Note: editing Format Conditions is slow so performance improvements are quite limited

• I utilized your code and at first was amazed at the speed! Upon further review, your extra conditional IF requiring the offset to be positive was with good intentions, but the way my offset works, is actually negative so the speed that it operated at was misleading (it was exiting before .formatconditions were touched). The code structure and variable declaration strategy you used is truly helpful and I will use it to learn and further improve my VBA proficiency. I will leave the question open as the performance did not change with your code, though it is much easier to read and understand. – Sam Buford Apr 9 '18 at 18:40
• I’m glad it helped. I didn’t know the exact requirements and didn’t have test data to verify but the main idea abot the offset is to make sure it doesn’t go outside the valid range, so if we start in cell A1, this offset will be an error: Range(“A1”).Offset(-3, -3). I didn’t expect it would improve performance much but maybe others might provide alternatives. – paul bica Apr 10 '18 at 0:56