How to improve VBA Code for Monte Carlo Simulation

Question

I created a piece of code to consolidate each individual Monte-Carlo Simulation result into a single sheet. After each iteration, the macro merely stores the values of rows B6:DS6 in an array and writes them below row 6 at the end of the Simulation Output(1) page.

Even if I'm not an expert in VBA, the calculations still take a while, taking, for example, 15 minutes for 10.000 iterations. Additionally, I frequently receive one of the following error messages when I attempt to run simulations that number more than 5.000.

Sub MC_Sim()


'Varianblendeklaration
Dim Arr
Dim Outp
Dim i As Integer
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim MyTimer As Double


'Funktionen Aus
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Simulation Output (2)").EnableCalculation = False
Sheets("Grafiken").EnableCalculation = False


'Timer für Simulationszeit
StartTime = Timer


'Szenario auf Monte Carlo Simulation setzen
Sheets("Annahmen").Select
    Range("F41").Select
    Range("F41").Value = "Monte Carlo Simulation"


'Löschen vorhandener Werte in Outputsheet
Sheets("Simulation Output (1)").Select
    Range("B7:DS7").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    

'Kopieren und Output der Simulationswerte in Schleife über ein Array als Zwischenpspeicher
ReDim Outp(1 To Range("C1").Value, 1 To Range("B6:DS6").Columns.Count)

    For i = 1 To Range("C1")
        Arr = Range("B6:DS6").Value
        For S = 1 To UBound(Arr, 2)
           Outp(i, S) = Arr(1, S)
    Next
    
'Neuberechnung der Planzufallswerte in B6:DS6
Calculate
            
'Ausgabe Stausbar
SecondsElapsed = Round(Timer - StartTime, 2)
Application.StatusBar = "Simulation aktiv... I Fortschritt: " & i - 1 & " von " & Range("C1") & " Iterationen (" _
& Format((i - 1) / Range("C1"), "0%") & ") I Rechenzeit (Min:Sek): " & Format(SecondsElapsed / 60 / 60 / 24, "nn:ss")
    
Next
        
'Zurückschreiben der Werte aus dem Array in das Tabellenblatt
Range("B7").Resize(UBound(Outp, 1), UBound(Outp, 2)) = Outp


'Simulationszeit in Sekunden
Sheets("Simulation Output (1)").Select
    Range("C2").Value = SecondsElapsed


'Szenario zurück auf Base Case
Sheets("Annahmen").Select
    Range("F41").Select
    Range("F41").Value = "Base Case"


'Simulationszeit in Sekunden
Sheets("Simulation Output (1)").Select
        SecondsElapsed = Round(Timer - StartTime, 2)
        Range("C2").Value = SecondsElapsed

'Hinweis
MsgBox "Ende der Simulation! Rechenzeit (Min:Sek): " & Format(SecondsElapsed / 60 / 60 / 24, "nn:ss")


'Funktionen An
Application.ScreenUpdating = True
Application.EnableEvents = True
Sheets("Simulation Output (2)").EnableCalculation = True
Sheets("Grafiken").EnableCalculation = True


'Zurücksetzen der Statusleiste und Löschen des Clipboards
Application.StatusBar = False
Application.CutCopyMode = False

End Sub

See Code above, however, the Code is still slow and I get error messages for higher iterations.

Answer 1

Try this:

Option Explicit
Sub MC_Sim()
    
    'Varianblendeklaration
    Dim Arr
    Dim Outp
    Dim I As Long
    Dim S As Long
    Dim Lrow As Long
    Dim Xval As Long
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    Dim MyTimer As Double
    
    'Funktionen Aus
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    'Timer für Simulationszeit
    StartTime = Timer
    
    'Szenario auf Monte Carlo Simulation setzen
    Sheets("Annahmen").Range("F41").Value = "Monte Carlo Simulation"

    'Löschen vorhandener Werte in Outputsheet
    With Sheets("Simulation Output (1)")
        Lrow = .Range("B7").End(xlDown).Row
        .Range("B7:DS" & Lrow).ClearContents
            
        'Kopieren und Output der Simulationswerte in Schleife über ein Array als Zwischenpspeicher
        Xval = .Range("C1").Value
        ReDim Outp(1 To Xval, 1 To .Range("B6:DS6").Columns.Count)
        
        For I = 1 To Xval
            Arr = .Range("B6:DS6")
            For S = 1 To UBound(Arr, 2)
               Outp(I, S) = Arr(1, S)
            Next S
                
            'Neuberechnung der Planzufallswerte in B6:DS6
            Calculate
                        
            'Ausgabe Stausbar
            SecondsElapsed = Round(Timer - StartTime, 2)
            Application.StatusBar = "Simulation aktiv... I Fortschritt: " & I - 1 & " von " & Xval & " Iterationen (" _
            & Format((I - 1) / Xval, "0%") & ") I Rechenzeit (Min:Sek): " & Format(SecondsElapsed / 60 / 60 / 24, "nn:ss")
                
        Next I
                
        'Zurückschreiben der Werte aus dem Array in das Tabellenblatt
        .Range("B7").Resize(UBound(Outp, 1), UBound(Outp, 2)) = Outp
        
        'Simulationszeit in Sekunden
        .Range("C2").Value = SecondsElapsed
        
        'Szenario zurück auf Base Case
        Sheets("Annahmen").Range("F41").Value = "Base Case"
        
        'Simulationszeit in Sekunden
        SecondsElapsed = Round(Timer - StartTime, 2)
        .Range("C2").Value = SecondsElapsed
        
        'Hinweis
        MsgBox "Ende der Simulation! Rechenzeit (Min:Sek): " & Format(SecondsElapsed / 60 / 60 / 24, "nn:ss")
        
    End With
    
    'Funktionen An
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    'Zurücksetzen der Statusleiste und Löschen des Clipboards
    Application.StatusBar = False
    Application.CutCopyMode = False

End Sub