trjhtr

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)
  
  


• 
  

  Not sure about this line:

  
  
  

  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