# How to make VBA code faster



## Monicasinha (Jan 4, 2023)

Hi

I am using the below VBA code. This is for updating charts, formatting, adding data labels.
It is taking long time to process. Can you please help.
----------------------------------------------------------------------------------------------------------------------------------------------

Sub ColorByCategoryLabel()

Dim x As Integer

Dim varValues As Variant

Dim iCategory As Long

Dim rCategory As Range

Dim Series As Long

Dim i As Long

Dim labelStr As String

Dim saveAsFilename As String

Dim ErrorMessage As String

Application.EnableEvents = False

Application.ScreenUpdating = False

With ActiveSheet

For y = 111 To 121

RH = 14

If .Cells(y, 63) <= 0 Then RH = 0

.Cells(y, 63).RowHeight = RH

Next y

End With


Set cht = ActiveSheet.ChartObjects("AChart").Chart

For ISeries = 1 To 6

With cht.SeriesCollection(ISeries)

varValues = .XValues

For x = LBound(varValues) To UBound(varValues)

Select Case ISeries

Case 1, 5, 6

.Points(x).Interior.ColorIndex = xlNone

End Select

Next

End With

Next

With cht.SeriesCollection(3)

varValues = .XValues

For x = LBound(varValues) To UBound(varValues)

If varValues(x) = "CR" Then

.Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS2").Interior.Color

ElseIf varValues(x) = "B SD²" Then

.Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS2").Interior.Color

ElseIf varValues(x) = "MR³" Then

.Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS3").Interior.Color

Else: .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS3").Interior.Color

End If

Next

End With

With cht.SeriesCollection(2)

varValues = .XValues

For x = LBound(varValues) To UBound(varValues)

If varValues(x) = "B SD²" Then

.Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS4").Interior.Color

ElseIf varValues(x) = "MR³" Then

.Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS5").Interior.Color

With .Points(x).Format.Fill

.Patterned msoPatternWideUpwardDiagonal

End With



End If

Next

End With

With cht.SeriesCollection(4)

varValues = .XValues

For x = LBound(varValues) To UBound(varValues)

If varValues(x) = "B SD²" Then

.Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS6").Interior.Color

ElseIf varValues(x) = "MR³" Then

.Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS5").Interior.Color

With .Points(x).Format.Fill

.Patterned msoPatternWideUpwardDiagonal

End With

End If

Next

End With

With cht.SeriesCollection(3)

varValues = .XValues

For x = LBound(varValues) To UBound(varValues)

saveAsFilename = Environ("temp") & "\temp.png"



If Not ExportImage(saveAsFilename, ActiveSheet.Shapes("Diamond 1"), ErrorMessage) Then

MsgBox ErrorMessage, vbCritical, "Error"

Exit Sub

End If



If varValues(x) = "B Price (per CTA)" Then

With .Points(x).Format.Fill

.Visible = msoTrue

.UserPicture saveAsFilename

.TextureTile = msoFalse

Kill saveAsFilename

End With

End If



saveAsFilename = Environ("temp") & "\temp.png"



If Not ExportImage(saveAsFilename, ActiveSheet.Shapes("Star 1"), ErrorMessage) Then

MsgBox ErrorMessage, vbCritical, "Error"

Exit Sub

End If



If varValues(x) = "Client Budget" Then

With .Points(x).Format.Fill

.Visible = msoTrue

.UserPicture saveAsFilename

.TextureTile = msoFalse

Kill saveAsFilename

End With

End If

With cht.SeriesCollection(3)

If varValues(x) = "B SD²" Then

cht.SeriesCollection(3).Points(x).HasDataLabel = _

True

cht.SeriesCollection(3).Points(x).DataLabel.Text = "Standard"

cht.SeriesCollection(3).Points(x).DataLabel.Font.Color = RGB(0, 0, 0)

ElseIf varValues(x) = "MR³" Then

cht.SeriesCollection(3).Points(x).HasDataLabel = _

True

cht.SeriesCollection(3).Points(x).DataLabel.Text = "50th"

cht.SeriesCollection(3).Points(x).DataLabel.Font.Color = RGB(0, 0, 0)

End If

End With

With cht.SeriesCollection(2)

If varValues(x) = "B SD²" Then

cht.SeriesCollection(2).Points(x).HasDataLabel = _

True

cht.SeriesCollection(2).Points(x).DataLabel.Text = "Invested"

cht.SeriesCollection(2).Points(x).DataLabel.Font.Color = RGB(0, 0, 0)

ElseIf varValues(x) = "MR³" Then

cht.SeriesCollection(2).Points(x).HasDataLabel = _

True

cht.SeriesCollection(2).Points(x).DataLabel.Text = "25th"

cht.SeriesCollection(2).Points(x).DataLabel.Font.Color = RGB(0, 0, 0)

End If

End With

With cht.SeriesCollection(4)

If varValues(x) = "B SD²" Then

cht.SeriesCollection(4).Points(x).HasDataLabel = _

True

cht.SeriesCollection(4).Points(x).DataLabel.Text = "Differentiated"

cht.SeriesCollection(4).Points(x).DataLabel.Font.Color = RGB(0, 0, 0)

ElseIf varValues(x) = "MR³" Then

cht.SeriesCollection(4).Points(x).HasDataLabel = _

True

cht.SeriesCollection(4).Points(x).DataLabel.Text = "75th"

cht.SeriesCollection(4).Points(x).DataLabel.Font.Color = RGB(0, 0, 0)

End If

End With
Next
End With

Application.ScreenUpdating = True
Application.EnableEvents = True



End Sub


----------



## johnnyL (Jan 4, 2023)

@Monicasinha, in the future please use code tags when supplying code.

I have looked at your code and tried to shorten up the code the best I can without having a workbook to test it on.

Please test out the code on a copy of your workbook to verify if I messed anything up when I shortened the code, yet 


```
Option Explicit

Sub ColorByCategoryLabel()
'
    Dim x               As Long, y      As Long
    Dim ISeries         As Long
    Dim RH              As Long
    Dim ErrorMessage    As String
    Dim saveAsFilename  As String
    Dim varValues       As Variant
'
    Dim cht
'
      Application.EnableEvents = False
    Application.ScreenUpdating = False
'----------------------------------------------------------------------------------------------------
    With ActiveSheet
        For y = 111 To 121
            RH = 14
'
            If .Cells(y, 63) <= 0 Then RH = 0
'
            .Cells(y, 63).RowHeight = RH
        Next y
    End With
'----------------------------------------------------------------------------------------------------
    Set cht = ActiveSheet.ChartObjects("AChart").Chart
'
'    For ISeries = 1 To 6
'        With cht.SeriesCollection(ISeries)
'            varValues = .XValues
'
'            For x = LBound(varValues) To UBound(varValues)
'                Select Case ISeries
'                    Case 1, 5, 6
'                        .Points(x).Interior.ColorIndex = xlNone
'                End Select
'            Next
'        End With
'    Next
'
'
'
    For ISeries = 1 To 6
        Select Case ISeries
            Case 1, 5, 6
                With cht.SeriesCollection(ISeries)
                    varValues = .XValues
'
                    For x = LBound(varValues) To UBound(varValues)
                        .Points(x).Interior.ColorIndex = xlNone
                    Next
                End With
        End Select
    Next
'----------------------------------------------------------------------------------------------------
    With cht.SeriesCollection(3)
        varValues = .XValues
'
        For x = LBound(varValues) To UBound(varValues)
            If varValues(x) = "CR" Or varValues(x) = "B SD²" Then
                .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS2").Interior.Color
            Else
                .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS3").Interior.Color
            End If
        Next
    End With
'----------------------------------------------------------------------------------------------------
    For y = 2 To 4 Step 2
        With cht.SeriesCollection(y)
            varValues = .XValues
'
            For x = LBound(varValues) To UBound(varValues)
                If y = 2 And varValues(x) = "B SD²" Then
                    .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS4").Interior.Color
                End If
'
                If y = 4 And varValues(x) = "B SD²" Then
                    .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS6").Interior.Color
                End If
'
                If varValues(x) = "MR³" Then
                    .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS5").Interior.Color
'
                    With .Points(x).Format.Fill
                        .Patterned msoPatternWideUpwardDiagonal
                    End With
                End If
            Next
        End With
    Next
'----------------------------------------------------------------------------------------------------
    With cht.SeriesCollection(3)
        varValues = .XValues
'
        For x = LBound(varValues) To UBound(varValues)
            saveAsFilename = Environ("temp") & "\temp.png"
'
            If Not ExportImage(saveAsFilename, ActiveSheet.Shapes("Diamond 1"), ErrorMessage) Or _
                    Not ExportImage(saveAsFilename, ActiveSheet.Shapes("Star 1"), ErrorMessage) Then
                MsgBox ErrorMessage, vbCritical, "Error"
                Exit Sub
            End If
'
            If varValues(x) = "B Price (per CTA)" Or varValues(x) = "Client Budget" Then
                With .Points(x).Format.Fill
                    .Visible = msoTrue
                    .UserPicture saveAsFilename
                    .TextureTile = msoFalse
'
                    Kill saveAsFilename
                End With
            End If
'----------------------------------------------------------------------------------------------------
            For y = 2 To 4
                With cht.SeriesCollection(y)
                    If varValues(x) = "B SD²" Or varValues(x) = "MR³" Then
                        cht.SeriesCollection(y).Points(x).HasDataLabel = True
                        cht.SeriesCollection(y).Points(x).DataLabel.Font.Color = RGB(0, 0, 0)
                    End If
'
                    If y = 2 Then
                        If varValues(x) = "B SD²" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "Invested"
                        If varValues(x) = "MR³" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "25th"
                    End If
'
                    If y = 3 Then
                        If varValues(x) = "B SD²" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "Standard"
                        If varValues(x) = "MR³" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "50th"
                    End If
'
                    If y = 4 Then
                        If varValues(x) = "B SD²" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "Differentiated"
                        If varValues(x) = "MR³" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "75th"
                    End If
                End With
            Next
        Next
    End With
'
    Application.ScreenUpdating = True
      Application.EnableEvents = True
End Sub
```


----------



## Monicasinha (Jan 5, 2023)

Thank you so much Johnny! This worked. You are a genius!


----------



## johnnyL (Jan 5, 2023)

It worked much faster? How much faster? Please provide some details.


----------



## Monicasinha (Jan 5, 2023)

Hi Johnny- Some new issues encountered.
After running the vba couple of times noticed that the speed reduced. In the first to around 5th attempt, it took couple of seconds.. now taking a minute.
If I reopen the file, speed again reduces to a couple of seconds.. It is when I am working on the same file and running the macros again and again that the speed starts to reducing.

Also, I realised later that the shape "star" is coming for both "B Price (per CTA)" and "Client Budget". I want diamond for "B Price (per CTA)" and start for "Client Budget".
Could you please look into this.

Thanks.


----------



## johnnyL (Jan 5, 2023)

Monicasinha said:


> Also, I realised later that the shape "star" is coming for both "B Price (per CTA)" and "Client Budget". I want diamond for "B Price (per CTA)" and start for "Client Budget".



Can you explain further what you are asking for?


----------



## Monicasinha (Jan 5, 2023)

1.  The speed of VBA running increases with multiple running of the code. Can we do something about it so that speed is always fast whether I hit the macros button once or multiple times while working on the workbook.

2. This code below always gives Star 1 image even if Value is "B Price (per CTA)". 
It should work like this:
If Value is B Price (per CTA), then Star 1 Image
If Value is Client Budget, then Diamond 1 Image

--------------------------------------------------------------------------------------------------------------------------------

With cht.SeriesCollection(3)
        varValues = .XValues
'
        For x = LBound(varValues) To UBound(varValues)
            saveAsFilename = Environ("temp") & "\temp.png"
'
            If Not ExportImage(saveAsFilename, ActiveSheet.Shapes("Diamond 1"), ErrorMessage) Or _
                    Not ExportImage(saveAsFilename, ActiveSheet.Shapes("Star 1"), ErrorMessage) Then
                MsgBox ErrorMessage, vbCritical, "Error"
                Exit Sub
            End If
'
            If varValues(x) = "B Price (per CTA)" Or varValues(x) = "Client Budget" Then
                With .Points(x).Format.Fill
                    .Visible = msoTrue
                    .UserPicture saveAsFilename
                    .TextureTile = msoFalse
'
                    Kill saveAsFilename
                End With
            End If


----------



## johnnyL (Jan 5, 2023)

Try this version which has that section replaced with the original code:


```
Sub ColorByCategoryLabel()
'
    Dim x               As Long, y      As Long
    Dim ISeries         As Long
    Dim RH              As Long
    Dim ErrorMessage    As String
    Dim saveAsFilename  As String
    Dim varValues       As Variant
'
    Dim cht
'
      Application.EnableEvents = False
    Application.ScreenUpdating = False
'----------------------------------------------------------------------------------------------------
    With ActiveSheet
        For y = 111 To 121
            RH = 14
'
            If .Cells(y, 63) <= 0 Then RH = 0
'
            .Cells(y, 63).RowHeight = RH
        Next y
    End With
'----------------------------------------------------------------------------------------------------
    Set cht = ActiveSheet.ChartObjects("AChart").Chart
'
    For ISeries = 1 To 6
        Select Case ISeries
            Case 1, 5, 6
                With cht.SeriesCollection(ISeries)
                    varValues = .XValues
'
                    For x = LBound(varValues) To UBound(varValues)
                        .Points(x).Interior.ColorIndex = xlNone
                    Next
                End With
        End Select
    Next
'----------------------------------------------------------------------------------------------------
    With cht.SeriesCollection(3)
        varValues = .XValues
'
        For x = LBound(varValues) To UBound(varValues)
            If varValues(x) = "CR" Or varValues(x) = "B SD²" Then
                .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS2").Interior.Color
            Else
                .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS3").Interior.Color
            End If
        Next
    End With
'----------------------------------------------------------------------------------------------------
    For y = 2 To 4 Step 2
        With cht.SeriesCollection(y)
            varValues = .XValues
'
            For x = LBound(varValues) To UBound(varValues)
                If y = 2 And varValues(x) = "B SD²" Then
                    .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS4").Interior.Color
                End If
'
                If y = 4 And varValues(x) = "B SD²" Then
                    .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS6").Interior.Color
                End If
'
                If varValues(x) = "MR³" Then
                    .Points(x).Format.Fill.ForeColor.RGB = ActiveSheet.Range("BS5").Interior.Color
'
                    With .Points(x).Format.Fill
                        .Patterned msoPatternWideUpwardDiagonal
                    End With
                End If
            Next
        End With
    Next
'----------------------------------------------------------------------------------------------------
    With cht.SeriesCollection(3)
        varValues = .XValues
'
        For x = LBound(varValues) To UBound(varValues)
            saveAsFilename = Environ("temp") & "\temp.png"
'
            If Not ExportImage(saveAsFilename, ActiveSheet.Shapes("Diamond 1"), ErrorMessage) Then
                MsgBox ErrorMessage, vbCritical, "Error"
                Exit Sub
            End If
'
            If varValues(x) = "B Price (per CTA)" Then
                With .Points(x).Format.Fill
                    .Visible = msoTrue
                    .UserPicture saveAsFilename
                    .TextureTile = msoFalse
'
                    Kill saveAsFilename
                End With
            End If
'
            saveAsFilename = Environ("temp") & "\temp.png"
'
            If Not ExportImage(saveAsFilename, ActiveSheet.Shapes("Star 1"), ErrorMessage) Then
                MsgBox ErrorMessage, vbCritical, "Error"
                Exit Sub
            End If
'
            If varValues(x) = "Client Budget" Then
                With .Points(x).Format.Fill
                    .Visible = msoTrue
                    .UserPicture saveAsFilename
                    .TextureTile = msoFalse
'
                    Kill saveAsFilename
                End With
            End If
'----------------------------------------------------------------------------------------------------
            For y = 2 To 4
                With cht.SeriesCollection(y)
                    If varValues(x) = "B SD²" Or varValues(x) = "MR³" Then
                        cht.SeriesCollection(y).Points(x).HasDataLabel = True
                        cht.SeriesCollection(y).Points(x).DataLabel.Font.Color = RGB(0, 0, 0)
                    End If
'
                    If y = 2 Then
                        If varValues(x) = "B SD²" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "Invested"
                        If varValues(x) = "MR³" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "25th"
                    End If
'
                    If y = 3 Then
                        If varValues(x) = "B SD²" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "Standard"
                        If varValues(x) = "MR³" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "50th"
                    End If
'
                    If y = 4 Then
                        If varValues(x) = "B SD²" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "Differentiated"
                        If varValues(x) = "MR³" Then cht.SeriesCollection(y).Points(x).DataLabel.Text = "75th"
                    End If
                End With
            Next
        Next
    End With
'
    Application.ScreenUpdating = True
      Application.EnableEvents = True
End Sub
```

I am not sure what you can do about the speed decreasing with multiple runs. When Excel completes a script, it is supposed to free up the memory it used, but often it doesn't occur right away.


----------

