plotting Monte Carlo Simulation from excel sheet

Question

I have created the following code:

Option Explicit

Function EuropeanOption2(OptionType As String, Spot As Double, Strike As Double, RiskFreeInterest As Double, Volatility As Double, TimetoMaturity As Double, Dividend As Double, n As Double, Iterations As Double)
Dim m As Integer
Dim p As Integer
Dim OptionPayoff() As Double, St As Double, deltat As Double, random As Double, EuropeanOptionPrice As Double 

ReDim Payoff(1 To Iterations)

deltat = TimetoMaturity / n

Randomize

For m = 1 To Iterations
    St = Spot
    For p = 1 To n
        random = WorksheetFunction.NormSInv(Rnd())
        St = St * Exp((RiskFreeInterest - Dividend - volatility ^ 2 / 2) * deltat + Volatility * Sqr(deltat) * random)
    Next p

    If OptionType = "Call" Then 'Call or Put
        Payoff(m) = WorksheetFunction.Max(St - Strike, 0) * Exp(-RiskFreeInterest * TimetoMaturity)
    ElseIf OptionType = "Put" Then
        Payoff(m) = WorksheetFunction.Max(Strike - St, 0) * Exp(-RiskFreeInterest * TimetoMaturity)
    End If
Next m

For m = 1 To Iterations
    EuropeanOptionPrice = EuropeanOptionPrice + Payoff(m)
Next m

EuropeanOption2 = EuropeanOptionPrice / Iterations 

End Function

Sub Graph2()

Dim Column As Integer
Dim StartingValue As Integer
Dim StartingCell As Integer
Dim LastCell As Integer
Dim CallorPut As String
Dim cell As Integer

Application.ScreenUpdating = False

Application.Calculation = xlManual

Column = 1
StartingValue = 1
StartingCell = 15
LastCell = 15 + Range("G8")

Range("A" & StartingCell, "A" & LastCell).Formula = "=EuropeanOption2($B$4,$B$5,$B$6,$B$9,$B$8,$B$7,$B$10,$G$7,$A$13)"

'FOR 1000 simulations Range("B" & StartingCell, "B" & LastCell).Formula = "=EuropeanOption2($B$4,$B$5,$B$6,$B$9,$B$8,$B$7,$B$10,$G$7,$B$13)"

'For 10.000 simulations Range("C" & StartingCell, "C" & LastCell).Formula = "=EuropeanOption2($B$4,$B$5,$B$6,$B$9,$B$8,$B$7,$B$10,$G$7,$C$13)"

End Sub

As it takes forever to put in formulas for 1000 & 10.000+ simulations, I wanted to ask how to store the results in an array and plot these in the excel sheet and if this could help to speed up to computing process.

Answer 1

Monte Carlo Simulation

• The code took 8s to produce the result (A15:C34) in the screenshot.

• If you put all hard-coded values in constants at the beginning of the code, you'll know where to quickly find and modify them.
• Put all the values in variables and in data structures (only arrays here) and in the loop use them to 'feed' the function.
• Write the results to a 2D one-based one-column array to easily drop them in the one-column range. I didn't use one array with 3 columns to allow non-adjacent columns.
• I used Tim Williams' tip from the comments to modify the logic in the function a little bit.
• Unfortunately, I am Monte Carlo illiterate and have no clue what kind of numbers are to be used.
• In my short testing, when I used n = 200, it took forever, and finally WorksheetFunction.NormSInv failed which also failed once before. Maybe you ought to do something about it.

The Sub

Sub Graph2()
    Const ProcName As String = "Graph2"
    On Error GoTo ClearError

    Dim dT As Double: dT = Timer

    Const RowsCountAddress As String = "G8"
    Const EightsAddrList As String = "B4,B5,B6,B9,B8,B7,B10,G7"
    Const NinthAddrList As String = "A13,B13,C13" ' add more
    Const FirstRow As Long = 15

    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!

    Dim rCount As Long: rCount = ws.Range(RowsCountAddress).Value
       
    ' Store the lists and the values from the cells in arrays.
    
    ' First 8 arguments
    Dim EightsAddr() As String: EightsAddr = Split(EightsAddrList, ",")
    Dim eUpper As Long: eUpper = UBound(EightsAddr)
    
    Dim eArr() As Variant: ReDim eArr(0 To eUpper)
    
    Dim e As Long
    For e = 0 To eUpper
        eArr(e) = ws.Range(EightsAddr(e)).Value
    Next e
    Erase EightsAddr
    
    ' Ninth argument
    Dim NinthAddr() As String: NinthAddr = Split(NinthAddrList, ",")
    Dim nUpper As Long: nUpper = UBound(NinthAddr)
    
    Dim NinthVals() As Long: ReDim NinthVals(0 To nUpper)
    Dim NinthCols() As Long: ReDim NinthCols(0 To nUpper)
    
    Dim n As Long
    For n = 0 To nUpper
        With ws.Range(NinthAddr(n))
            NinthVals(n) = .Value
            NinthCols(n) = .Column
        End With
    Next n
    Erase NinthAddr
    
    ' Return the results in columns.
    
    Dim cData() As Double: ReDim cData(1 To rCount, 1 To 1)
    
    Dim crg As Range
    Dim r As Long
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        
    For n = 0 To nUpper
        For r = 1 To rCount
            cData(r, 1) = EuropeanOption2(eArr(0), eArr(1), eArr(2), eArr(3), _
                eArr(4), eArr(5), eArr(6), eArr(7), NinthVals(n))
        Next r
        With ws.Cells(FirstRow, NinthCols(n)).Resize(rCount)
            .Value = cData ' write
            .Resize(ws.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
        End With
    Next n
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Monte Carlo time: " & Format(Timer - dT, "0.000s."), vbInformation

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

The Function

Function EuropeanOption2( _
    ByVal OptionType As String, _
    ByVal Spot As Double, _
    ByVal Strike As Double, _
    ByVal RiskFreeInterest As Double, _
    ByVal Volatility As Double, _
    ByVal TimetoMaturity As Double, _
    ByVal Dividend As Double, _
    ByVal n As Long, _
    ByVal Iterations As Long) _
As Double
    Const ProcName As String = "EuropeanOption2"
    On Error GoTo ClearError
    
    Dim Deltat As Double: Deltat = TimetoMaturity / n
    
    Dim m As Long
    Dim p As Long
    
    Dim St As Double
    Dim Random As Double
    Dim PayOff As Double
    Dim EuropeanOptionPrice As Double
    
    Randomize
    
    For m = 1 To Iterations
        St = Spot
        PayOff = 0
        
        For p = 1 To n
            Random = WorksheetFunction.NormSInv(Rnd())
            St = St * Exp((RiskFreeInterest - Dividend - Volatility ^ 2 / 2) _
                * Deltat + Volatility * Sqr(Deltat) * Random)
        Next p
    
        Select Case OptionType
        Case "Call"
            If St > Strike Then
                PayOff = (St - Strike) * Exp(-RiskFreeInterest * TimetoMaturity)
            End If
        Case "Put"
            If Strike > St Then
                PayOff = (Strike - St) * Exp(-RiskFreeInterest * TimetoMaturity)
            End If
        Case Else ' oops
        End Select
        
        EuropeanOptionPrice = EuropeanOptionPrice + PayOff
    Next m
    
    EuropeanOption2 = EuropeanOptionPrice / Iterations

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function