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
Display More
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
Display More
My code is being slowed by this segment:
'Remove #REF! errors that have resulted due to deleting columns non relevant to sheet, however retain formula
Dim Calcs As Range
For Each Calcs In .Range("D11:G5010").SpecialCells(xlFormulas)
Calcs.Formula = Replace(Calcs.Formula, "#REF!", "0")
Next Calcs
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.