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