So after royUK kindly helped me get some bits of my macro working, I'm now looking at how I can run my macro more efficiently.

Using a steptimer method (in the module called 'Check'), I've managed to work out that >95% of the time it takes my code to run is dedicated to 4 lines of code.

The full code is:

- 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 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("D11:G5010").SpecialCells(xlFormulas)
- Calcs.Formula = Replace(Calcs.Formula, "#REF!", "0")
- Next Calcs
- '.Range("D11:G5010").SpecialCells(xlFormulas, xlErrors).Value = 0 <<don't think this achieves what I want
- 'Copy and paste RAU Calc values to enable descending sort - required for P10/P50/P90
- .Range("A11:C5010").Value2 = .Range("D11:F5010").Value2
- .Range("A11:C5010").Sort Key1:=.Range("C11"), Order1:=xlAscending, Key2:=.Range("B11"), Order1:=xlAscending, Key3:=.Range("B11"), Order1:=xlAscending
- '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)
- .Range("A2:A4").Value2 = Array("P10", "P50", "P90")
- .Range("B1:D1").Value2 = Array("Reliability", "Availability", "Utilisation")
- '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

With the AppSetting code provided by Roy:

- '---------------------------------------------------------------------------------------
- ' Module : Module1
- ' DateTime : 12/03/2006 08:42
- ' Author : Roy Cox (royUK)
- ' Purpose : Reset Application from one Procedure
- ' Disclaimer: This code is offered as is and the author
- ' accepts no responsibility for it's use.
- ' You may use this code freely, but please leave this header intact.
- '---------------------------------------------------------------------------------------
- '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

My code is being slowed by this segment:

Just prior to this segment of code, there is a section which deletes a number of columns which are not specific to the worksheet currently being worked on (and range of columns can change for each worksheet). As a result, the Formulas in D11:G5010 end up with #REF errors through them. I want to remove the reference error (currently being done by replacing it with 0) and retain the formula in the cell (as opposed to deleting the formula or cell).

Any suggestions on how to do this more efficiently?

I've also attached a sample of the workbook with most of the loop worksheets deleted to reduce file size and time to execute.