Suggestions to speed up VBA code

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:

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 Sub

And 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
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,072
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
You can replace the .Value with a replace no problem but the no cells found is more if a problem.
Are the formulas not producing a #REF error in the cells?
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
There's definitely still #REF errors in the cell.
Is it maybe to do with how I've input your code?

I've replaced the entire segment of
VBA Code:
Dim Calcs As Range
For Each Calcs In .Range("D10:G5010").SpecialCells(xlFormulas)
Calcs.Formula = Replace(Calcs.Formula, "#REF!", "0")
Next Calcs

with your segment
VBA Code:
.Range("D10:G5010").SpecialCells(xlFormulas, xlErrors).Value = 0

(which I guess with what you just said I can instead use: .Range("D10:G5010").SpecialCells(xlFormulas, xlErrors).Replace = 0 ??)
however that then gives me that No cells found error.
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,072
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
#Edited Post#

If it is picking up the cells with
VBA Code:
For Each Calcs In .Range("D10:G5010").SpecialCells(xlFormulas)
then I can see no reason why it would not pickup the cells with
VBA Code:
.Range("D10:G5010").SpecialCells(xlFormulas, xlErrors)
if they are showing a #REF! error, and they did when I tested this code
VBA Code:
Sub test()
Sheet1.Range("A1:A10").SpecialCells(xlFormulas, xlErrors).Interior.ColorIndex = 6
End Sub
I got
Book1
ABC
11111
2#REF!12
31313
41414
51515
6#REF!16
71717
81818
9#REF!19
102020
Sheet1
Cell Formulas
RangeFormula
A1,A3:A5,A7:A8,A10A1=C1
A2,A6,A9A2=#REF!D2


As for the replace then you need to use the same syntax for the replace part as you were using in your previous code i.e.

VBA Code:
.Range("D10:G5010").SpecialCells(xlFormulas, xlErrors).Replace "#REF!", "XXX!", xlPart

Replacing the "XXX!" with whatever you want.
 
Last edited:

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
Thanks Mark - I can see how the code works now.
I can also see no reason why it's not picking up the cells in the range - however for some reason it still works with the original code but not the replacement!
As you can see from the screenshot, the cells definitely have errors in them but for some reason it won't pick this up. Any idea?

1616539689907.png
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,072
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile

ADVERTISEMENT

I can see why. Because you are using sum it isn't producing an error in the result so xlErrors isn't picking it up.

On a Test copy of the workbook what results do you get if you just do
VBA Code:
 .Range("D10:G5010").SpecialCells(xlFormulas).Replace "#REF!", "XXX!", xlPart
changing "XXX!" to what you want.
 

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
I can see why. Because you are using sum it isn't producing an error in the result so xlErrors isn't picking it up.

On a Test copy of the workbook what results do you get if you just do
VBA Code:
 .Range("D10:G5010").SpecialCells(xlFormulas).Replace "#REF!", "XXX!", xlPart
changing "XXX!" to what you want.
Hi Mark,

When I run this on a test sheet, the code doesn't get hung up but neither does it actually replace the "#REF!" error with "0". I tried it as well removing the SUM function and just keeping the cells as added within a brackets however it still did not like it.
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,072
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile

ADVERTISEMENT

Please upload a copy of your workbook to a free file hosting site like www.box.com or www.dropbox.com. Mark the file for sharing and post the link it provides in the thread.

Make sure that you amend any sensitive data before uploading.
 

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
Please upload a copy of your workbook to a free file hosting site like www.box.com or www.dropbox.com. Mark the file for sharing and post the link it provides in the thread.

Make sure that you amend any sensitive data before uploading.
Link as follows: Box

Code line we've been discussing is in there but inactive at the moment.
I've removed some of the extra worksheets and made it an xlsb file just to decrease the file size. Runs pretty quick with only the few worksheets but slows down exponentially in my actual file!
 

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
14,072
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
  2. Mobile
Which sheet has the #REF! error in F11? I am just getting ready for work now and so will try and look at it when I get back in tonight.
 

celebwen_orn

New Member
Joined
May 2, 2016
Messages
18
Which sheet has the #REF! error in F11? I am just getting ready for work now and so will try and look at it when I get back in tonight.
Hi Mark,

Every sheet with a name like Q*Y23/24/25 will have the #REF! errors in probably every cell of column E and F (because their formulas are dependent on entire columns which are deleted). No errors in the Q*Y22 sheets as all sitauations apply in the Y22.
Because I've currently got the 'slow' version of the code working to replace #REF! with '0', you'll see this in the formulas of these cells as '=((365/4)-G11+(J11+0+0+0+L11))/(365/4)'
 

Watch MrExcel Video

Forum statistics

Threads
1,130,340
Messages
5,641,576
Members
417,223
Latest member
jelena_

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 MrExcel.com.
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 "mrexcel.com".
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
Top