Suggestions to speed up VBA code

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
I've been trying to write my code as efficiently as possibly except I know I must be missing a few tricks because I've done something to it recently (by reordering it to try account for changes to cells, you'll see in the code there's a section I calculate formulas, followed by deleting columns, followed by replacing any #REF! due to the deleted columns with a blank to prevent it breaking - it's resulted in the code have to write a lot more data and hence slowing down but I can't figure out how else to do it) which made the code 5 times slower.

Current code takes my laptop about 120 second to run and only needs to loop across 6 worksheets. In the actual worksheet which has +20 tabs to loop through, it's taking about 350 seconds and I'm still missing 80% of the input data so would estimate it will end up taking >10mins.

Would anyone have any suggestions on how I could make this code more efficient to significantly speed it up? In the current format with limited sheets, I'd hope for it to take <30 seconds. Maybe something to do with arrays instead of constantly reading from the sheet (I tried it but it ended up taking longer so don't know what I did wrong!).

Code is also as below for those who wouldn't need to access the sheet:

VBA Code:
Sub HereGoes()

'Nice to have time how long macro takes
Dim StartTime As Double
Dim SecondsElapsed As Double
'Remember time when macro starts
  StartTime = Timer
 
'Speed up Macro by turning off calculations
Call AppSetting

' Define worksheets
Dim SRead As Worksheet, ws As Worksheet 'Source worksheet for data, All Q* worksheets
    Set SRead = ThisWorkbook.Worksheets("OP Inputs")
' Define the last row to transpose data for based on count in Column 4
Dim LastRow As Integer
    LastRow = SRead.Cells(SRead.Rows.Count, 3).End(xlUp).Row
    
'Copy to sheets with name like Q*Y*
For Each ws In Worksheets
If ws.Name Like "Q*" Then
With ws
    
'Define all other integers
Dim LastColumn As Integer, LastColumn2 As Integer, i As Integer, i2 As Integer, i3 As Integer
    LastColumn = .Cells(5, .Columns.Count).End(xlToLeft).Column - 8
    LastColumn2 = (.Cells(5, .Columns.Count).End(xlToLeft).Column - 8) / 2
    
' Copy across titles to every 2nd column
For i = 1 To LastRow
Dim ColumnX As Range
    Set ColumnX = SRead.Cells(i, 24)
If Right$(ColumnX, 2) >= Right$(ws.Name, 2) Or Right$(ColumnX, 3) = "N/A" Then
    .Cells(4, 2 * i + 5).Value2 = SRead.Cells(i, 3).Value2
'Transpose across the LSD and associated likelihood (Note Value2 used as faster as does not check cell format)
    'Likelihood
     .Range(.Cells(5, 2 * i + 5), .Cells(8, 2 * i + 5)).Value2 = _
            WorksheetFunction.Transpose(SRead.Range("H" & i & ":K" & i).Value2)
     'Lost Stream Days
     .Range(.Cells(5, 2 * i + 6), .Cells(8, 2 * i + 6)).Value2 = _
            WorksheetFunction.Transpose(SRead.Range("L" & i & ":O" & i).Value2)
Else
    .Range(.Cells(5, 2 * i + 5), .Cells(8, 2 * i + 5)).Value2 = "N/A"
End If
Next i
    
'NOTE: FOLLOWING IS DEPENDANT ON THE REFERENCE CELLS REMAINING THE SAME
    'Column F to calculate reliability (excludes planned and uncontrollables)
    'Column E to calculate availability (excludes uncontrollables)
    'Column D to calculate utilisation (includes all)
    .Range("F11:F5010").FormulaR1C1 = "=((365/4)-RC[1]+sum(RC[6],RC[8],RC[10],RC[12],RC[14],,RC[16]))/(365/4)"
    .Range("E11:E5010").FormulaR1C1 = "=((365/4)-RC[2]+sum(RC[7],RC[9],RC[11],RC[13]))/(365/4)"
    .Range("D11:D5010").FormulaR1C1 = "=((365/4)-RC[3])/(365/4)"
    
'Delete columns where 'N/A' is in column H (D) on SRead, Row 6 on TRead (as above code)
Dim delColumns As Range
    Set delColumns = Nothing
For i = 2 To LastRow
    If .Cells(6, 2 * i + 5).Value2 = "N/A" Then
    'Store the Range to delete later or else counting for the columns screws up
    'Set the columns for deletion as the range of Column 2*i+4 and column to left
        If delColumns Is Nothing Then
            Set delColumns = .Range(.Columns(2 * i + 5), .Columns(2 * i + 6))
        Else
            Set delColumns = Application.Union(delColumns, .Range(.Columns(2 * i + 5), .Columns(2 * i + 6)))
        End If
    End If
Next i
If Not delColumns Is Nothing Then delColumns.Delete

'Fill out every other columns for 5000 random probablisitic trials
Dim t As Integer: t = 1
Dim t1 As Integer: t1 = 1
Dim arr(1 To 5000, 1 To 1) As Variant
    For trial = 1 To 5000 Step 1
        arr(t1, 1) = trial
        t1 = t1 + 1
    Next trial
'Place array values in Cell G11 and every 2nd column to match probabilistic trials
    For i = 1 To LastColumn2
    .Cells(11, 2 * i + 7).Resize(5000).Value2 = arr
    Next i
'Insert Vlookup in first cell using random variable between 0-1
'to search probabilities (i.e G5:G8) with an absolute reference (R1C1 notation)
    For i = 1 To LastColumn2
    .Cells(11, 2 * i + 8).FormulaR1C1 = "=VLOOKUP(RAND(),R5C[-1]:R8C,2)"
'Now copy this absolute formula to other cells
    .Range(.Cells(12, 2 * i + 8), .Cells(5010, 2 * i + 8)).Formula = .Cells(11, 2 * i + 8).Formula
    Next i
    
'Fill out random columns for overall calcs. Use arrays where possible for speed
'Insert trials to column H to allow P10, P50, P90 determination
Dim trialF As Variant
For trialF = 0.0002 To 1 Step 0.0002
    arr(t, 1) = trialF
    t = t + 1
Next trialF
.Cells(11, 8).Resize(5000).Value2 = arr
'Insert formula to Column G for sum of all LSD
Set f1 = .Cells(11, 10)
    For i = 1 To LastColumn Step 2
        Set f1 = Union(f1, .Cells(11, 9 + i))
    Next i
Set f2 = .Cells(11, "G")
    For i2 = 1 To 4999 Step 1
        Set f2 = Union(f2, .Cells(11 + i2, "G"))
    Next i2
f2.Formula = "=sum(" & f1.Address(0, 0) & ")"
    
Dim Calcs As Range
For Each Calcs In .Range("D10:G5010").SpecialCells(xlFormulas)
Calcs.Formula = Replace(Calcs.Formula, "#REF!", "0")
Next Calcs

'Copy and paste RAU Calc values to enable descending sort - required for P10/P50/P90
    .Range("A11:C5010").Value2 = .Range("D11:F5010").Value2
    .Range("C11:C5010").Sort Key1:=.Range("C11"), Order1:=xlAscending, Header:=xlNo
    .Range("B11:B5010").Sort Key1:=.Range("B11"), Order1:=xlAscending, Header:=xlNo
    .Range("A11:A5010").Sort Key1:=.Range("A11"), Order1:=xlAscending, Header:=xlNo

'Calculate overall Reliability, Availability & Utilisation for quarter
Dim ColHeadings As Variant, RowHeadings As Variant
ColHeadings = VBA.Array("P10", "P50", "P90")
.Range("A2:A4").Value2 = Application.WorksheetFunction.Transpose(ColHeadings)
RowHeadings = VBA.Array("Reliability", "Availability", "Utilisation")
.Range("B1:D1").Value2 = RowHeadings
'Insert formula to look up P10/P50/P90 matches
.Cells(2, 2).FormulaR1C1 = "=INDEX(R11C1:R5010C1,MATCH(90%,R11C8:R5010C8))"
.Cells(3, 2).FormulaR1C1 = "=INDEX(R11C1:R5010C1,MATCH(50%,R11C8:R5010C8))"
.Cells(4, 2).FormulaR1C1 = "=INDEX(R11C1:R5010C1,MATCH(10%,R11C8:R5010C8))"
.Cells(2, 3).FormulaR1C1 = "=INDEX(R11C2:R5010C2,MATCH(90%,R11C8:R5010C8))"
.Cells(3, 3).FormulaR1C1 = "=INDEX(R11C2:R5010C2,MATCH(50%,R11C8:R5010C8))"
.Cells(4, 3).FormulaR1C1 = "=INDEX(R11C2:R5010C2,MATCH(10%,R11C8:R5010C8))"
.Cells(2, 4).FormulaR1C1 = "=INDEX(R11C3:R5010C3,MATCH(90%,R11C8:R5010C8))"
.Cells(3, 4).FormulaR1C1 = "=INDEX(R11C3:R5010C3,MATCH(50%,R11C8:R5010C8))"
.Cells(4, 4).FormulaR1C1 = "=INDEX(R11C3:R5010C3,MATCH(10%,R11C8:R5010C8))"
'Requires For statement with nested if. First if: If InStr(1,SRead.Cells(i,17), "Q1") Then


'Consider adding code to colour the columns with probabilities and random trials and Name Table after Worksheet name
    .Range(.Range("I5"), .Range("I5").End(xlDown).End(xlToRight)).Interior.ColorIndex = 36
    .Range(.Range("I11"), .Range("I11").End(xlDown).End(xlToRight)).Interior.ColorIndex = 35
    .Range(.Range("H11"), .Range("H11").End(xlDown)).Interior.ColorIndex = 34
    .Range(.Range("G11"), .Range("G11").End(xlDown)).Interior.ColorIndex = 37
    .Range(.Range("F11"), .Range("F11").End(xlDown).End(xlToLeft)).Interior.ColorIndex = 15
'   .ListObjects.Add(xlSrcRange, Range("A1:D4"), , xlYes).Name = TRead.Name
'   .ListObjects(TRead.Name).TableStyle = "Table Style 1"

'    ActiveWindow.SmallScroll Down:=-18
'    Range("Table1[#All]").Select
'    ActiveSheet.ListObjects("Table1").TableStyle = "Table Style 1"

End With
End If
Next ws

'Turn back on calculation functionalities
 Call AppSetting("Reset")

'Sheets("OP Inputs").Select

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
  MsgBox "Code took " & SecondsElapsed & " seconds to run", vbInformation

End Sub

And then the AppSetting code was developed by royUK:

Code:
'Get current settings
Dim lCalc      As Long
Dim sOldSbar   As String

Public Sub AppSetting(Optional arg1 As String = "")
    If arg1 = "" Then
        lCalc = Application.Calculation
        sOldSbar = Application.DisplayStatusBar
        sOldAlerts = Application.DisplayAlerts
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .DisplayStatusBar = True
            .StatusBar = "Please wait, busy just now...."
        End With
    Else
        With Application
            .Calculation = lCalc
            .ScreenUpdating = True
            .DisplayAlerts = True
            .EnableEvents = True
            .StatusBar = False
            .DisplayStatusBar = sOldSbar
        End With
    End If
End Sub
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
Thanks for sharing that silentwolf - I haven't seen the break down timers before as a method of diagnoses.

I broke it down for the formula running on a single worksheet.
For the single worksheet, code took about 17.4 seconds

This section of the code accounts for ~17 seconds:

VBA Code:
Dim Calcs As Range
For Each Calcs In .Range("D10:G5010").SpecialCells(xlFormulas)
Calcs.Formula = Replace(Calcs.Formula, "#REF!", "0")
Next Calcs

Any suggestions on how I could make this run faster? The intention of this section of the code is to search all formulas in the range "D10:G5010" for #REF! errors which have been caused by earlier parts of the code deleting non-relevant columns, and replacing them with "0" to prevent the error occurring.
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,205
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows

ADVERTISEMENT

If you no longer need the formula
why not
VBA Code:
Dim Calcs As Range
For Each Calcs In .Range("D10:G5010").SpecialCells(xlFormulas)
Calcs.Formula = "0"
Next Calcs
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,072
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
Are there any other errors in the column other than #REF that need keeping?
 

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18

ADVERTISEMENT

Are there any other errors in the column other than #REF that need keeping?
No, no other errors occurring in the column and I certainly don't need to keep any error even if there were! Sounds like you might have an idea for me...
 

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
Hi Michael, I still need the formula, I just need to get rid of any #REF! errors in the formula so that it will actually calculate
If you no longer need the formula
why not
VBA Code:
Dim Calcs As Range
For Each Calcs In .Range("D10:G5010").SpecialCells(xlFormulas)
Calcs.Formula = "0"
Next Calcs
 

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
I can't actually get the above to run (Error message: No cells were found) but correct me if I'm wrong Mark - will the above not instead set the cell value to 0 if there is an error in the formula?

I want the formula to still be able to calculate even if there was an error in it.
So for example if the cell F11 in the range D10:G5010 contained:

=((365/4)-G11+SUM(J11,L11,N11,#REF!,P11,R11))/(365/4)
before running the section of code (and therefore not calculate), afterwards it would return:

=((365/4)-G11+SUM(J11,L11,N11,0,P11,R11))/(365/4)
which it can calculate
 

Watch MrExcel Video

Forum statistics

Threads
1,130,340
Messages
5,641,576
Members
417,223
Latest member
jelena_

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
Top