Reduce time taken for VBA loop

[sjedi]

My VBA code currently loops for 5,000 iterations and takes about 25 minutes to collect the output data in the Output excel sheet. Is there a way to reduce the time taken for instance by improving the copying and pasting of values, collecting the output data in some kind of array etc.? Given that I will be looping it for up to 10,000 iterations when I obtain more data
Note: The calculations are excel formulas within the Calcs excel sheet, as this is a cash flow schedule with irregular cash flows and discount rates, hence I am unable to automate the cash flow calculations via VBA.

Sub x()

Dim r As Long
Dim lastrow As Long

Application.ScreenUpdating = False
Application.CutCopyMode = False

With Worksheets("MCInput")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
MsgBox lastrow - 1 & " Trials"
End With

With Worksheets("Calcs")
    For r = 0 To (lastrow - 2)
        .Range("CASHINPUT").Value = Worksheets("MCInput").Range("TCASHRTN").Offset(r).Value
        .Range("EQINPUT").Value = Worksheets("MCInput").Range("TEQRTN").Offset(r).Value
        .Range("FIINPUT").Value = Worksheets("MCInput").Range("TFIRTN").Offset(r).Value
        .Range("Results").Calculate
        .Range("Results").Copy
        Worksheets("Output").Range("A1").Offset(1 + r, 1).PasteSpecial xlPasteValues
    Next r
End With

Application.ScreenUpdating = True
Application.CutCopyMode = True

End Sub

 

[QuietRiot]

don't calculate after every iteration. Change all values first. Calculate once. Then add another function to create the output

 

[sjedi]

Hi QuietRiot, could you provide the modifications to my code? I don't quite understand how to change all the values first and calculate only once. The input to the cash flow schedule consists of 5,000 sets of discount rates over a time period and I am iterating through the 5,000 sets of discount rates to check several statistics of the cash flow schedule

 

[QuietRiot]

Comment out this line: '.Range("Results").Calculate and see how long it takes to run

 

[Peter_SSs]

Comment out this line: '.Range("Results").Calculate and see how long it takes to run

I think that you are missing the point that the OP is cycling through putting different values in the same cells and collecting each result/s from the same "Results" range & recording it/them. If the calculation isn't done each time then the relevant result/s will not be collected in the other sheet

 

[DanteAmor]

Hi @sjedi, welcome to the board!

If the calculation is in automatic, then the "results" range is calculated in automatic.
I also assume that the "results" range is a single cell, if so, try the following:

Sub x()
  Dim r As Long, lastrow As Long, a As Variant
 
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationAutomatic
 
  With Worksheets("MCInput")
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    'MsgBox lastrow - 1 & " Trials"
  End With
 
  ReDim a(1 To lastrow - 1, 1 To 1)
  With Worksheets("Calcs")
    For r = 0 To (lastrow - 2)
      .Range("CASHINPUT").Value = Worksheets("MCInput").Range("TCASHRTN").Offset(r).Value
      .Range("EQINPUT").Value = Worksheets("MCInput").Range("TEQRTN").Offset(r).Value
      .Range("FIINPUT").Value = Worksheets("MCInput").Range("TFIRTN").Offset(r).Value
      a(r + 1, 1) = .Range("Results").Value
    Next r
  End With
  Worksheets("Output").Range("B2").Resize(UBound(a), 1).Value = a
End Sub

Let me know any questions.

 

[StephenCrump]

Similar approach to DanteAmor, but with less read/write to Excel, and assuming Results is a vector, rather than scalar:

Sub x()

    Dim r As Long, i As Long, NoRows As Long, NoCols As Long, j as Long
    Dim vInput1 As Variant, vInput2 As Variant, vInput3 As Variant, vOut As Variant, vResults As Variant
   
    Application.ScreenUpdating = False
   
    With Worksheets("MCInput")
        NoRows = .Cells(.Rows.Count, "B").End(xlUp).Row - .Range("TCASHRTN").Row + 1
        vInput1 = .Range("TCASHRTN").Resize(NoRows).Value
        vInput2 = .Range("TEQRTN").Resize(NoRows).Value
        vInput3 = .Range("TFIRTN").Resize(NoRows).Value
    End With
    NoCols = Worksheets("Calcs").Range("Results").Columns.Count
    ReDim vResults(1 To NoRows, 1 To NoCols)
   
    With Worksheets("Calcs")
        For r = 1 To NoRows
            .Range("CASHINPUT").Value = vInput1(r, 1)
            .Range("EQINPUT").Value = vInput2(r, 1)
            .Range("FIINPUT").Value = vInput3(r, 1)
            vOut = .Range("Results").Value
            For j = 1 To NoCols
                vResults(r, j) = vOut(1, j)
            Next j
        Next r
    End With
   
    Worksheets("Output").Range("B1").Resize(NoRows, NoCols).Value = vResults
    Application.ScreenUpdating = True

End Sub

 

[sjedi]

Similar approach to DanteAmor, but with less read/write to Excel, and assuming Results is a vector, rather than scalar:

Sub x()

    Dim r As Long, i As Long, NoRows As Long, NoCols As Long, j as Long
    Dim vInput1 As Variant, vInput2 As Variant, vInput3 As Variant, vOut As Variant, vResults As Variant
  
    Application.ScreenUpdating = False
  
    With Worksheets("MCInput")
        NoRows = .Cells(.Rows.Count, "B").End(xlUp).Row - .Range("TCASHRTN").Row + 1
        vInput1 = .Range("TCASHRTN").Resize(NoRows).Value
        vInput2 = .Range("TEQRTN").Resize(NoRows).Value
        vInput3 = .Range("TFIRTN").Resize(NoRows).Value
    End With
    NoCols = Worksheets("Calcs").Range("Results").Columns.Count
    ReDim vResults(1 To NoRows, 1 To NoCols)
  
    With Worksheets("Calcs")
        For r = 1 To NoRows
            .Range("CASHINPUT").Value = vInput1(r, 1)
            .Range("EQINPUT").Value = vInput2(r, 1)
            .Range("FIINPUT").Value = vInput3(r, 1)
            vOut = .Range("Results").Value
            For j = 1 To NoCols
                vResults(r, j) = vOut(1, j)
            Next j
        Next r
    End With
  
    Worksheets("Output").Range("B1").Resize(NoRows, NoCols).Value = vResults
    Application.ScreenUpdating = True

End Sub

Hi @StephenCrump, thanks for the above code, it certainly helps with speeding up my loop! @DanteAmor, thanks for the code as well; however my "results" range is actually a row of 40 numbers i.e. 1 x 40 range. Each of the Input variables is also a 1 x 40 range

I have tried to modify @StephenCrump code to take into account the 40 columns, but I cannot seem to get the desired output. Could anyone help me identify my error in modifying the code?

  With Worksheets("Calcs")
        For r = 1 To NoRows
            .Range("CASHINPUT").Value = vInput1(r, NoCols)
            .Range("EQINPUT").Value = vInput2(r, NoCols)
            .Range("FIINPUT").Value = vInput3(r, NoCols)
            vOut = .Range("Results").Value
            For j = 1 To NoCols
                vResults(r, j) = vOut(1, j)
            Next j
        Next r

Here is a one-line sample of the coded outputs versus the correct outputs (if I perform a manual copy inputs > calculate > copy outputs)

Correct results

1.002504​

1.002785​

1.004093​

1.00365​

1.003903​

1.005234​

1.007471​

1.007693​

1.007962​

1.006351​

1.006411​

1.00677​

1.007252​

1.007739​

1.010425​

1.012463​

1.012803​

1.014042​

1.01285​

1.013106​

1.014452​

1.016772​

1.019125​

1.025109​

1.029745​

1.033777​

1.041337​

1.050963​

1.060425​

1.064487​

1.066871​

1.085129​

1.108313​

1.123232​

1.138931​

1.176082​

1.199691​

1.231487​

1.303482​

1.428934​

Coded results

1.001803​

1.002393​

1.002976​

1.003553​

1.004123​

1.004686​

1.005243​

1.005795​

1.006341​

1.006881​

1.007417​

1.007947​

1.008473​

1.008995​

1.009512​

1.010025​

1.010543​

1.011073​

1.011619​

1.012186​

1.012796​

1.015183​

1.017657​

1.020235​

1.022942​

1.025805​

1.028864​

1.032167​

1.035778​

1.039782​

1.044296​

1.049487​

1.055592​

1.062976​

1.072211​

1.084265​

1.100906​

1.125615​

1.16653​

1.248174​

Differential

0.0007​

0.000393​

0.001117​

9.77E-05​

-0.00022​

0.000549​

0.002228​

0.001899​

0.001621​

-0.00053​

-0.00101​

-0.00118​

-0.00122​

-0.00126​

0.000913​

0.002438​

0.00226​

0.002969​

0.001231​

0.00092​

0.001656​

0.001589​

0.001468​

0.004873​

0.006803​

0.007972​

0.012472​

0.018796​

0.024647​

0.024705​

0.022575​

0.035642​

0.052721​

0.060256​

0.06672​

0.091817​

0.098785​

0.105872​

0.136952​

0.18076​

 

[DanteAmor]

@DanteAmor, thanks for the code as well; however my "results" range is actually a row of 40 numbers i.e. 1 x 40 range. Each of the Input variables is also a 1 x 40 range

I put my macro updated for the number of columns that have the range "Results", try and tell me.

Sub x2()
  Dim r As Long, lastrow As Long, a As Variant, b As Variant, j As Long
 
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationAutomatic
 
  With Worksheets("MCInput")
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
'    MsgBox lastrow - 1 & " Trials"
  End With
 
  With Worksheets("Calcs")
    ReDim a(1 To lastrow - 1, 1 To .Range("results").Columns.Count)
    For r = 0 To (lastrow - 2)
      .Range("CASHINPUT").Value = Worksheets("MCInput").Range("TCASHRTN").Offset(r).Value
      .Range("EQINPUT").Value = Worksheets("MCInput").Range("TEQRTN").Offset(r).Value
      .Range("FIINPUT").Value = Worksheets("MCInput").Range("TFIRTN").Offset(r).Value
      b = .Range("Results").Value
      For j = 1 To UBound(b, 2)
        a(r + 1, j) = b(1, j)
      Next
    Next r
  End With
  Worksheets("Output").Range("B2").Resize(UBound(a), UBound(b, 2)).Value = a
End Sub

 

[StephenCrump]

... my "results" range is actually a row of 40 numbers i.e. 1 x 40 range. Each of the Input variables is also a 1 x 40 range

If I'm reading this correctly, TCASHRTN, TEQRTN, and TFIRTN are 5,000 x 40, i.e perhaps 5,000 sets of discount rates for 40 durations and CASHINPUT, EQINPUT and FIINPUT are each 1 x 40?

In which case:

Sub x()

    Dim r As Long, i As Long, NoRows As Long, NoCols As Long, j As Long
    Dim vInput1 As Variant, vInput2 As Variant, vInput3 As Variant, vOut As Variant, vResults As Variant
  
    Application.ScreenUpdating = False
  
    With Worksheets("MCInput")
        NoRows = .Cells(.Rows.Count, "B").End(xlUp).Row - .Range("TCASHRTN").Row + 1
        vInput1 = .Range("TCASHRTN").Resize(NoRows).Value
        vInput2 = .Range("TEQRTN").Resize(NoRows).Value
        vInput3 = .Range("TFIRTN").Resize(NoRows).Value
    End With
    NoCols = Worksheets("Calcs").Range("Results").Columns.Count
    ReDim vResults(1 To NoRows, 1 To NoCols)
  
    With Worksheets("Calcs")
        For r = 1 To NoRows
            .Range("CASHINPUT").Value = Application.Index(vInput1, r, 0)
            .Range("EQINPUT").Value = Application.Index(vInput2, r, 0)
            .Range("FIINPUT").Value = Application.Index(vInput3, r, 0)
            vOut = .Range("Results").Value
            For j = 1 To NoCols
                vResults(r, j) = vOut(1, j)
            Next j
        Next r
    End With
  
    Worksheets("Output").Range("B1").Resize(NoRows, NoCols).Value = vResults
    Application.ScreenUpdating = True

End Sub

Or you could do this slightly differently, with a counter variable N in the worksheet, and using INDEX() in Excel in lieu of the three code lines below. This will allow you to look in detail at the Nth calculation in Worksheets("Calcs"). The VBA then simply needs to loop from 1 to 5,000.

.Range("CASHINPUT").Value = Application.Index(vInput1, r, 0)
.Range("EQINPUT").Value = Application.Index(vInput2, r, 0)
.Range("FIINPUT").Value = Application.Index(vInput3, r, 0)