How to make VBA code faster

M

Monicasinha

Board Regular
Joined
Dec 26, 2022
Messages
51
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
@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 :)

VBA Code: 
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
 
Upvote 0
It worked much faster? How much faster? Please provide some details.
 
Upvote 0
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.
 
Upvote 0
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".
Click to expand...

Can you explain further what you are asking for?
 
Upvote 0
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
 
Upvote 0
Try this version which has that section replaced with the original code:

VBA 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.
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
368
Minh Tuan VN
M
A
  • Question Question
VBA script delete row containing specific text
Replies
1
Views
764
DanteAmor
DanteAmor
B
  • Question Question
Prevent Line from Continuing Point-to-Point (Non-continuous) On Scatter Plot in VBA
Replies
1
Views
768
Jon Peltier
J
E
  • Question Question
Can anyone help me get my VBA code working? I have spent tons of time but can't quite fix it.
Replies
3
Views
3K
profray
P
E
  • Question Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
545
offthelip
O

Forum statistics

Threads
1,224,825
Messages
6,181,190
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top