1
\$\begingroup\$

How can I improve my VBA code to run faster?

The issue I'm having is that the For/Next commands are taking ~10 hours to calculate and print all of the data. I cannot turn of calculations because I need the values calculated for every node (check_nodes).

I have 1 sheet ("Rating") that performs calculations (25) for every check_node (944 nodes) of all check_trucks (38 trucks) so that's \$25\times944\times38=896800\$ data points that are compiled then printed to different sheets for each of the 38 trucks. The results & format I'm getting are correct I just need to speed up the code somehow.

Originally I was going to run the VBA individually for all 38 trucks but then decided to modify the code to run all trucks automatically. Unfortunately this increased run time dramatically.

Sub Perform_Rating_Check()

Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer

'------------------------
'DETERMINE NUMBER OF ROWS OF DATA FOR LOAD RATING SUMMARY
'------------------------

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False

    Sheets("Output").Activate
    Row = Range("Start.Nodes").Row
    Column = Range("Start.Nodes").Column

    startRow = Range("Start.Nodes").Row
    nrows = Range("Num_Checks").Value

    ReDim check_nodes(1 To nrows)
    For q = 1 To nrows
        check_nodes(q) = Cells(startRow - 1 + q, Column)
    Next

'------------------------------
'CALCULATE & PRINT LOAD RATINGS
'------------------------------

    ReDim PR_summary(1 To nrows, 1 To 26)

    Sheets("Rating").Activate
    Truck_row = Range("Start.Truck").Row
    Truck_col = Range("Start.Truck").Column

    ntrucks = Range("Num.Trucks").Value

    ReDim check_trucks(1 To ntrucks)
    For k = 1 To ntrucks
        check_trucks(k) = Cells(Truck_row - 1 + k, Truck_col)
    Next

    For j = 1 To ntrucks
        TruckSheet = check_trucks(j)
        Range("Choose.Truck") = check_trucks(j)
        Sheets(TruckSheet).Activate
             For s = 1 To nrows
                Range("Check_Location") = check_nodes(s)
                PR_row = Range("A9").Row - 1
                PR_col = Range("A9").Column - 1
                Cells(PR_row + s, PR_col + 1) = check_nodes(s)
                Cells(PR_row + s, 2) = Range("RF_INV_Axial").Value
                Cells(PR_row + s, 3) = Range("RF_INV_Major").Value
                Cells(PR_row + s, 4) = Range("RF_INV_Minor").Value
                Cells(PR_row + s, 5) = Range("RF_OPR_Axial").Value
                Cells(PR_row + s, 6) = Range("RF_OPR_Major").Value
                Cells(PR_row + s, 7) = Range("RF_OPR_Minor").Value
                Cells(PR_row + s, 8) = Range("RF_INV_Axial_My").Value
                Cells(PR_row + s, 9) = Range("RF_INV_Major_My").Value
                Cells(PR_row + s, 10) = Range("RF_INV_Minor_My").Value
                Cells(PR_row + s, 11) = Range("RF_OPR_Axial_My").Value
                Cells(PR_row + s, 12) = Range("RF_OPR_Major_My").Value
                Cells(PR_row + s, 13) = Range("RF_OPR_Minor_My").Value
                Cells(PR_row + s, 14) = Range("RF_INV_Axial_Mz").Value
                Cells(PR_row + s, 15) = Range("RF_INV_Major_Mz").Value
                Cells(PR_row + s, 16) = Range("RF_INV_Minor_Mz").Value
                Cells(PR_row + s, 17) = Range("RF_OPR_Axial_Mz").Value
                Cells(PR_row + s, 18) = Range("RF_OPR_Major_Mz").Value
                Cells(PR_row + s, 19) = Range("RF_OPR_Minor_Mz").Value
                Cells(PR_row + s, 20) = Range("RF_INV_Shear_P").Value
                Cells(PR_row + s, 21) = Range("RF_INV_Shear_My").Value
                Cells(PR_row + s, 22) = Range("RF_INV_Shear_Mz").Value
                Cells(PR_row + s, 23) = Range("RF_OPR_Shear_P").Value
                Cells(PR_row + s, 24) = Range("RF_OPR_Shear_My").Value
                Cells(PR_row + s, 25) = Range("RF_OPR_Shear_Mz").Value
            Next s
    Next j

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True

End Sub

I like how the data is printed currently but I just want it to run much faster. Last time I ran the code it took about 10 hours to complete.

\$\endgroup\$
  • 1
    \$\begingroup\$ Possible duplicate of How To Speed Up VBA Code \$\endgroup\$ – Andrew Morton May 23 '19 at 15:14
  • \$\begingroup\$ 2 things seem off to me, but it may be related to other cells in your sheet: 1) You are setting PR_summary, then setting the Cells(PR_row + s) to its value, why not just miss out the PR_Summary and set the cells right away? 2) MUCH more importantly, if you could, can you switch off the calculation for as much as possible? I'm wiling to bet that if you did that, your code will run MUCH faster! \$\endgroup\$ – John Bustos May 23 '19 at 15:21
  • \$\begingroup\$ Did you try reverting the nesting of the loops? (meaning, making the inner loop to be the outer and vise-versa). \$\endgroup\$ – FDavidov May 23 '19 at 15:22
  • \$\begingroup\$ @JohnBustos I need the "Rating" sheet to recalculate the PR_summary values for all check_nodes. Wouldn't turning off calculation make all of the PR_summary values identical? Would setting the cells right away look something like this Cells(PR_row + s, 1) = Range("RF_INV_Axial").Value instead? \$\endgroup\$ – tuckman321 May 23 '19 at 15:25
  • \$\begingroup\$ @JohnBustos, I'm not sure if my recollection is correct... Automatic recalculation is not triggered till the macro ends (it makes no sense to recalculate the whole book each update of a cell). \$\endgroup\$ – FDavidov May 23 '19 at 15:26
4
\$\begingroup\$

It's not super-clear to me what's going on here but this stands out as cell-by-cell data transfer, which is pretty slow:

   For s = 1 To nrows
        Range("Check_Location") = check_nodes(s)
        PR_row = Range("A9").Row - 1      '<< why not just =8?
        PR_col = Range("A9").Column - 1   '<<     and = 0 ?
        Cells(PR_row + s, PR_col + 1) = check_nodes(s)
        Cells(PR_row + s, 2) = Range("RF_INV_Axial").Value
        Cells(PR_row + s, 3) = Range("RF_INV_Major").Value
        'etc etc 
        Cells(PR_row + s, 25) = Range("RF_OPR_Shear_Mz").Value
    Next s

Would be faster if you set all 25 values in a single call:

   For s = 1 To nrows
        Range("Check_Location") = check_nodes(s)
        PR_row = Range("A9").Row - 1      '<< why not just =8?
        PR_col = Range("A9").Column - 1   '<<     and = 0 ?
        Cells(PR_row + s, PR_col + 1).resize(1,25).value = _
            Array(check_nodes(s), Range("RF_INV_Axial").Value, _
                  Range("RF_INV_Major").Value,{etc etc} ,Range("RF_OPR_Shear_Mz").Value)
    Next s

Also as John suggests, switch calculation to Manual, and call Calculate on your formulas sheet when you're ready for the next set of values to be created.

\$\endgroup\$
3
\$\begingroup\$

You are missing Option Explicit at the top of your code module. Add it. From the menu Tools>Options to display the Options dialog.

enter image description here

In the Options dialog>Editor tab>Code Settings group>Require Variable Declaration ensure it has a check mark next to it.

enter image description here

Your future-self will thank you for doing so. This mandates you declare any variables Dim foo as Long before you can use them anywhere in your code foo = 10. You will save yourself so much frustration by doing this.


You're using unqualified Ranges objects. This leads to a two-fold issue. First what is an unqualified Range? Range("Foo") instead of specifiedSheet.Range("Foo"). By not fully qualifying the sheet the range is using whatever-happens-to-be the ActiveSheet to get that Range. This is a problem because you then need to use Worksheet.Activate method to first activate the sheet then hope/pray/wish that another sheet doesn't get activated while your code is running. Activating a sheet is a liability and isn't needed.

An example of this is the ambiguity it causes with named ranges. Is Range("Start.Nodes") scoped to the worksheet that is active or is it scoped to the workbook? I can't tell from the code itself. My refactoring is going to assume that they are scoped to a worksheet.


You are using the default member of the Range object. What's this? Using specifiedSheet.Range() or specifiedSheet.Cells(,) instead of specifiedSheet.Range().Value2. In the first you're implicitly using it to get the value of the cell, the second it's explicitly shown. You can see this in the Object Browser, shown by pressing F2 in the VBE. Making sure hidden members are shown and navigating to the Range class then to Default. The teal icon indicates it's the default member.

enter image description here

If your curious why Value2 is used read up on TEXT vs VALUE vs VALUE2 – Slow TEXT and how to avoid it by Charles Williams.


You have comment block style headers.

'------------------------
'DETERMINE NUMBER OF ROWS OF DATA FOR LOAD RATING SUMMARY
'------------------------

Comments should say why somethings done that way. The what should be apparent by using adequately descriptive names. This applies to all names whether they are for a variable, Function, Sub, etc. A clear name that states what it is, or is doing makes your code self-documenting. You have an example of this with your variables. Dim startRow as Long states that it is the start row. Then you also have q, k, j, s, nrows, etc. That's not helping readability at all.


You can also create a specific function and return what it's named. This lets you break down the steps into small modular pieces. An example follows.

Private Function GetCheckNodes(ByVal topLeftCell As Range, ByVal numberOfRows As Long) As Variant
    GetCheckNodes = Application.WorksheetFunction.Transpose(topLeftCell.Resize(numberOfRows, 1))
End Function

Application.WorksheetFunction.Transpose is used to transpose the array from a 2D array to a 1D array. Where this function is used you provide arguments to the parameters.

Dim checkNodes As Variant
checkNodes = GetCheckNodes(outputSheet.Range("Start.Nodes"), numberOfRows)

Be sure to limiting the information that's provided to these function to only what it actually needs to know in order to achieve the task. This takes a bit of refactoring and examining what the code is or should be doing but in the long run helps clear things up a lot.


When you have contiguous ranges that span multiple rows or columns don't pick up each one individually. Think of a bag marbles on the counter top and picking them up one at a time. That's what you're doing. Since you know the start and end rows you ---can--- should get the entire range all at once and store it in a variable. The example refactoring above shows just this. You originally had

ReDim check_nodes(1 To nrows)
For q = 1 To nrows
    check_nodes(q) = Cells(startRow - 1 + q, Column)
Next

Rewritten as topLeftCell.Resize(numberOfRows, 1). It uses the Range.Resize property to resize the range selection and get it in a single step. Instead of picking up 1, 5, 100, or 10,000 cells you get a single range object. Much faster.


You use underscores _ in variable names. This is the convention that you use when an object implements an interface done by using the Implements statement.


These were caught after my refactoring with https://github.com/rubberduck-vba/Rubberduck, of which I'm a contributing member:

Your Sub statement for Sub Perform_Rating_Check() doesn't have an access modifier. Because of this it is implicitly public.

Your calls to Sheets are implicitly referencing the ActiveWorkbook.


Taking all the above into consideration I came up with the below code. The variable names are descriptive and let you know what they are for. There are subs that are specialized to do one thing, and only that one thing.

As I'm not sure about your named ranges I assumed they were on specific sheets. If that's wrong and they're scoped to the workbook then ThisWorkbook.Range("foo") will get them working.

Option Explicit

Const lowerBoundColumnTransfer As Long = 1
Const upperBoundColumnTransfer As Long = 25

Public Sub PerformRatingCheck()
    Dim StartTime As Double
    StartTime = Timer

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False

    Dim outputSheet As Worksheet
    Set outputSheet = ThisWorkbook.Sheets("Output") 'Can be referred to by its code name

    Dim numberOfRows As Long
    numberOfRows = outputSheet.Range("Num_Checks").Value2

    Dim checknodes As Variant
    checknodes = GetCheckNodes(outputSheet.Range("Start.Nodes"), numberOfRows)

    Dim ratingSheet As Worksheet
    Set ratingSheet = ThisWorkbook.Sheets("Rating") 'Can be referred to by its code name

    Dim numberOfTrucks As Long
    numberOfTrucks = ratingSheet.Range("Num.Trucks").Value2

    Dim namesOfTruckSToCheck As Variant
    namesOfTruckSToCheck = GetNamesOfTrucksToCheck(ratingSheet.Range("Start.Truck"), ratingSheet.Range("Num.Trucks").Value2)

    Dim truckName As Variant
    For Each truckName In namesOfTruckSToCheck
        PopulateTruckSheet ThisWorkbook.Sheets(truckName), checknodes
    Next

    Dim SecondsElapsed As Double
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
End Sub

Private Function GetCheckNodes(ByVal topLeftCell As Range, ByVal numberOfRows As Long) As Variant
    GetCheckNodes = Application.WorksheetFunction.Transpose(topLeftCell.Resize(numberOfRows, 1))
End Function

Private Function GetNamesOfTrucksToCheck(ByVal firstTruckCell As Range, ByVal numberOfTrucks As Long) As Variant
    GetNamesOfTrucksToCheck = firstTruckCell.Resize(numberOfTrucks, 1).Value2
End Function

Private Sub PopulateTruckSheet(ByVal truckSheet As Worksheet, ByVal checknodes As Variant)
    'Unable to definitively determine which sheet named range is on.
    'Assuming it's on scoped to each worksheet. If scoped to workbook
    'replace truckSheet with Thisworkbook
    truckSheet.Range("Choose.Truck").Value2 = truckSheet.Name

    Dim truckInfo As Variant
    truckInfo = GetTruckInformation(truckSheet, checknodes)

    Const PR_row As Long = 8
    Dim populationArea As Range
    Set populationArea = truckSheet.Cells(PR_row + 1, 1).Resize(UBound(truckInfo), UBound(truckInfo, 2))
    populationArea.Value2 = truckInfo
End Sub

Private Function GetTruckInformation(ByVal sourceSheet As Worksheet, ByVal checknodes As Variant) As Variant
    Dim tempArray As Variant
    ReDim tempArray(LBound(checknodes) To UBound(checknodes), lowerBoundColumnTransfer To upperBoundColumnTransfer)

    Dim counter As Long
    For counter = LBound(checknodes) To UBound(checknodes)
        Dim checkNode As String
        checkNode = checknodes(counter)
        sourceSheet.Range("Check_Location").Value2 = checkNode

        Dim truckInfoForRow As Variant
        truckInfoForRow = GetTruckInformationForRow(sourceSheet, checkNode)

        Dim columnTransfer As Long
        For columnTransfer = lowerBoundColumnTransfer To upperBoundColumnTransfer
            tempArray(counter, columnTransfer) = truckInfoForRow(columnTransfer)
        Next
    Next counter

    GetTruckInformation = tempArray
End Function

Private Function GetTruckInformationForRow(ByVal sourceSheet As Worksheet, ByVal checkNode As String) As Variant
    'If these are workbook scoped named ranges the parameter sourceSheet can be deleted
    Dim tempArray As Variant
    ReDim tempArray(lowerBoundColumnTransfer To upperBoundColumnTransfer)
    tempArray(1) = checkNode
    tempArray(2) = sourceSheet.Range("RF_INV_Axial").Value2
    tempArray(3) = sourceSheet.Range("RF_INV_Major").Value2
    tempArray(4) = sourceSheet.Range("RF_INV_Minor").Value2
    tempArray(5) = sourceSheet.Range("RF_OPR_Axial").Value2
    tempArray(6) = sourceSheet.Range("RF_OPR_Major").Value2
    tempArray(7) = sourceSheet.Range("RF_OPR_Minor").Value2
    tempArray(8) = sourceSheet.Range("RF_INV_Axial_My").Value2
    tempArray(9) = sourceSheet.Range("RF_INV_Major_My").Value2
    tempArray(10) = sourceSheet.Range("RF_INV_Minor_My").Value2
    tempArray(11) = sourceSheet.Range("RF_OPR_Axial_My").Value2
    tempArray(12) = sourceSheet.Range("RF_OPR_Major_My").Value2
    tempArray(13) = sourceSheet.Range("RF_OPR_Minor_My").Value2
    tempArray(14) = sourceSheet.Range("RF_INV_Axial_Mz").Value2
    tempArray(15) = sourceSheet.Range("RF_INV_Major_Mz").Value2
    tempArray(16) = sourceSheet.Range("RF_INV_Minor_Mz").Value2
    tempArray(17) = sourceSheet.Range("RF_OPR_Axial_Mz").Value2
    tempArray(18) = sourceSheet.Range("RF_OPR_Major_Mz").Value2
    tempArray(19) = sourceSheet.Range("RF_OPR_Minor_Mz").Value2
    tempArray(20) = sourceSheet.Range("RF_INV_Shear_P").Value2
    tempArray(21) = sourceSheet.Range("RF_INV_Shear_My").Value2
    tempArray(22) = sourceSheet.Range("RF_INV_Shear_Mz").Value2
    tempArray(23) = sourceSheet.Range("RF_OPR_Shear_P").Value2
    tempArray(24) = sourceSheet.Range("RF_OPR_Shear_My").Value2
    tempArray(25) = sourceSheet.Range("RF_OPR_Shear_Mz").Value2

    GetTruckInformationForRow = tempArray
End Function

There may be more that can be done I've already speculated too much regarding your named ranges.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy