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:
And then the AppSetting code was developed by royUK:
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 SubAnd 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
