Suggestions to speed up VBA code

[celebwen_orn]

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:

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:

'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

 

[MARK858]

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.

 

[celebwen_orn]

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 box.com to work this morning

 

[MARK858]

That site comes up as malicious on my AV software. Please retry Box or use Dropbox.

 

[celebwen_orn]

That site comes up as malicious on my AV software. Please retry Box or use Dropbox.

Finally got it working on another laptop. Sorry for the faff.

VBA file

 

[MARK858]

Your file for me shows #REF! in the cell which gets picked up with

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

Sub test2()
Sheets("Q1Y24").Range("E11:E5010").SpecialCells(xlFormulas, xlErrors).Replace What:="#REF!", Replacement:="zzz", LookAt:=xlPart, FormulaVersion:=xlReplaceFormula2
End Sub

 

[celebwen_orn]

Mark, if you actually replace that code into the code in my file, instead of the segment

'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?

 

[MARK858]

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