2
\$\begingroup\$

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
Improve this question
\$\endgroup\$
0

1 Answer 1

Reset to default
2
\$\begingroup\$

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

Improve this answer
\$\endgroup\$
2
  • 1
    \$\begingroup\$ 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. \$\endgroup\$
    – Sam Buford
    Apr 9, 2018 at 18:40
  • 1
    \$\begingroup\$ 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. \$\endgroup\$
    – paul bica
    Apr 10, 2018 at 0:56

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.