Suggestions to speed up VBA code


New Member
May 2, 2016
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)
     .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)
    .Range(.Cells(5, 2 * i + 5), .Cells(8, 2 * i + 5)).Value2 = "N/A"
End If
Next i
    '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))
            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:

'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
        With Application
            .Calculation = lCalc
            .ScreenUpdating = True
            .DisplayAlerts = True
            .EnableEvents = True
            .StatusBar = False
            .DisplayStatusBar = sOldSbar
        End With
    End If
End Sub
Post a workbook with the #REF! errors showing please. There is no point me testing on a workbook that isn't set-up exactly as you have it with the errors.
Upvote 0

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Mark, I've inactivated the section of code which currently removes the #REF! errors in this following file (but left it in the code so you can see the placement and what I'm trying to speed up):
VBA File

Apologies it's on 4shared - can't get to work this morning
Upvote 0
That site comes up as malicious on my AV software. Please retry Box or use Dropbox.
Upvote 0
Your file for me shows #REF! in the cell which gets picked up with

VBA Code:
Sub test()
Sheets("Q1Y24").Range("E11:E5010").SpecialCells(xlFormulas, xlErrors).Interior.ColorIndex = 6
End Sub

What I see....


and the below code done the replacement fine

VBA Code:
Sub test2()
Sheets("Q1Y24").Range("E11:E5010").SpecialCells(xlFormulas, xlErrors).Replace What:="#REF!", Replacement:="zzz", LookAt:=xlPart, FormulaVersion:=xlReplaceFormula2
End Sub
Last edited:
Upvote 0
Mark, if you actually replace that code into the code in my file, instead of the segment

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

Do you still get the same results? When I run your code in isolation, it seems to work fine however if I try to include it in my original code in place of what I originally had, I still get that same error for 'No cells were found' though you can clearly see yourself that on every page looped through, the #REF error is present in that range.

I suspect it might be something to do with the fact that the calculations are turned off whilst the whole code runs? And as a result it doesn't 'see' the #REF error because that only shows up if the calculations are on?
Last edited:
Upvote 0
I suspect it might be something to do with the fact that the calculations are turned off whilst the whole code runs? And as a result it doesn't 'see' the #REF error because that only shows up if the calculations are on?
Then turn the calculations back on before the line and back off after the line or just do a Calculate (a full Calculate on your workbook took 0.062 seconds on my computer with another workbook open).
Upvote 0

Forum statistics

Latest member
DW Draft

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
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 "".
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