VBA Execution Speed Has Extreme Variation for No Apparent Reason

jbcpub

New Member
Joined
May 6, 2021
Messages
4
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hello, I have an Excel macro that with the same exact inputs has wildly different execution speeds. Most of the time, the macro completes in approximately 19 seconds, but for no apparent reason, it will start completing in less than 1 second and do it consistently. I've included the piece of code below that has the largest impact on execution speed. It usually takes around 17 seconds (of the 19 total) but when the macro executes fast will complete in less than .25 seconds.

I disable all the typical application updates. The rng variable is of type Range and contains multiple non-contiguous columns.

Any thoughts on how to have the macro consistently complete in less than a second?

VBA Code:
With Application
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .DisplayAlerts = False
    .EnableEvents = False
    .EnableAnimations = False
    .Calculation = xlCalculationManual
End With

Worksheets(glbMainWSName).DisplayPageBreaks = False

rng.EntireColumn.ColumnWidth = glbColumnWidth 'this seems to be orders of magnitude slower than any other portion of the macro
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Here's the complete code. Sub Click_Filter is called when a user double clicks in a cell.

VBA Code:
Option Explicit

Public Const glbMainWSName As String = "ALL"
Public Const glbMainTable As String = "Table_Main"
Public Const glbColumnFindFirst As String = "END DEVICE"
Public Const glbColumnFindLast As String = "NOTES"
Public Const glbEffectRow As Integer = 6
Public Const glbColumnWidth = 4.86

Public glbMainWS As Worksheet
Public glbStartTime As Double
Public glbLastCol As Range
Public glbFirstCol As Range


Sub Click_Filter(ByVal Target As Range, Cancel As Boolean)
    'Remember time when macro starts
    glbStartTime = Timer
    
    Call Update_Disable
      
    If Target.Row = glbEffectRow Then 'user is filtering on effects and not causes
        Call Filter_Remove
        Call Effect_FindCol 'find effect columns
        glbMainWS.Range(glbFirstCol, glbLastCol).EntireColumn.ColumnWidth = 0 'Hide All Effect Columns
        Target.EntireColumn.ColumnWidth = glbColumnWidth
        ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=Target.Column, Criteria1:="<>"
        ActiveWindow.ScrollColumn = 1 'scroll to the left after filtering
    
    Else 'user is filtering on causes
        If Target.Column = 3 Then 'Plant Area Column
            ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=3, Criteria1:=Target.Value
            Call Effect_Locate 'only show columns that have marked effects
        End If
            
        If Target.Column = 5 Then ' Tag Column
            ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=5, Criteria1:=Target.Value
            Call Effect_Locate 'only show columns that have marked effects
        End If
        
        If Target.Column = 6 Then ' Equipment Column
            ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=6, Criteria1:=Target.Value
            Call Effect_Locate 'only show columns that have marked effects
        End If
        
        If Target.Column = 7 Then 'Device Column
            ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=7, Criteria1:=Target.Value
            Call Effect_Locate 'only show columns that have marked effects
        End If
        
    End If
        
    ActiveWindow.ScrollRow = 8 'scroll to top of list after filtering

    Call Update_Enable
    
    Debug.Print Round(Timer - glbStartTime, 2)

End Sub

Sub Effect_Locate()
    Dim rng, Effect As Range
    Dim arr(0 To 4000) As Double
    Dim i, j As Integer
    Dim SecondsElapsed As Double
    Dim firstAddress As String
    Dim oDict As Object
    Dim key As Variant
    
    
    Set glbMainWS = Worksheets(glbMainWSName)
    
    Call Effect_FindCol 'find effect columns
      
    'iterate through effects columns
    
        i = 0
        For Each rng In glbMainWS.ListObjects(glbMainTable).ListColumns(7).DataBodyRange.SpecialCells(xlCellTypeVisible)
            
            Set rng = Range(glbMainWS.Cells(rng.Row, glbFirstCol.Column), glbMainWS.Cells(rng.Row, glbLastCol.Column))
            
            Set Effect = rng.Find(What:="*", _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                            
            If Not Effect Is Nothing Then 'at least one effect found
                firstAddress = Effect.Address
                Do
                    arr(i) = Effect.Column
                    i = i + 1
                    Set Effect = rng.FindNext(Effect)
                Loop While Not Effect Is Nothing And Effect.Address <> firstAddress
            End If
           
        Next rng

    
'Hide All Effect Columns
    glbMainWS.Range(glbFirstCol, glbLastCol).EntireColumn.ColumnWidth = 0 'using hidden = True/False seems to be slower than adjusting column width
     
 'Remove Duplicates from array
    Set oDict = CreateObject("Scripting.Dictionary")
    For j = 0 To i - 1
        oDict(arr(j)) = True
    Next
    
'Show Effect Columns That Were Identified to Have Marks
    Set rng = Nothing
    Debug.Print Round(Timer - glbStartTime, 2)
   
    For Each key In oDict.keys
    
        If rng Is Nothing Then
            Set rng = Cells(1, key)
        Else
            Set rng = Union(rng, Cells(1, key))
        End If
    Next key

    Debug.Print Round(Timer - glbStartTime, 2)
    rng.EntireColumn.ColumnWidth = glbColumnWidth 'this seems to be orders of magnitude slower than any other portion of the macro
     
    Set rng = Nothing

End Sub

Sub Effect_FindCol()
    Dim rng As Range
    
    Set glbMainWS = Worksheets(glbMainWSName)
    
    'Find first column of Effects
    With glbMainWS.Rows("6:6")
    Set rng = .Find(What:=glbColumnFindFirst, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
    End With
    Set glbFirstCol = rng.Offset(0, 1)
    
    'Find last column of Effects
    With glbMainWS.Rows("8:8")
    Set rng = .Find(What:=glbColumnFindLast, _
                            After:=.Cells(1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False)
    End With
    Set glbLastCol = rng.Offset(0, -1)

End Sub
Sub Filter_Remove()
   Dim rownum As Integer
   
   Call Update_Disable

    rownum = ActiveCell.Row 'get row number so that when the filters are cleared the last cell the user interacted with is scrolled to rather than the top of the worksheet

    Worksheets(glbMainWSName).ListObjects(glbMainTable).AutoFilter.ShowAllData 'clear row filter
    
    If glbFirstCol Is Nothing Or glbLastCol Is Nothing Then 'check that effect columns have been located
        Call Effect_FindCol
    End If
    
    Range(Cells(1, glbFirstCol.Column), Cells(1, glbLastCol.Column)).EntireColumn.ColumnWidth = 4.86 'show all effect columns
    
    ActiveWindow.ScrollRow = rownum
    
    Call Update_Enable
End Sub

Sub Update_Disable()
    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .DisplayAlerts = False
        .EnableEvents = False
        .EnableAnimations = False
        .Calculation = xlCalculationManual
    End With
    
    Worksheets(glbMainWSName).DisplayPageBreaks = False
End Sub

Sub Update_Enable()
    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .DisplayAlerts = True
        .EnableEvents = True
        .EnableAnimations = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
 
Upvote 0
I have a workaround. I've found that if I delete the first column after my data (or any column for that matter) then the macro consistently executes in less than a second. Even if I save after deleting the column, I have to repeat this each time I open the workbook. With this new information, anyone have any ideas on how to permanently fix this so that the columns don't have to be deleted each time or what the cause may be? I added code to automatically delete the column each time the workbook is open but I'd rather not rely on that plus there's no guarantees that it will continue to work in the future.
 
Upvote 0
The first thing to try is to turn off screen updating and autocalculation. Add the following code to the beginning of your code.

Application.ScreenUpdating = False
Application.Calculation = xlManual

At the end of your code, reverse them


Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
 
Upvote 0
The first thing to try is to turn off screen updating and autocalculation. Add the following code to the beginning of your code.

Application.ScreenUpdating = False
Application.Calculation = xlManual

At the end of your code, reverse them


Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
That's already in the code
 
Upvote 0

Forum statistics

Threads
1,213,515
Messages
6,114,080
Members
448,548
Latest member
harryls

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