I tried several tricks to simplify my VBA codes for running a Monte
Carlo simulation in an efficient fashion. My goal is to runs at
least 10,000 simulation trials each of which has at least 250 runs
(or trading days). I wonder if you could advise on how to speed up
this Monte Carlo simulation such that I can use these codes to
obtain the results for 9,000 observations (or companies).

This simulation applies a variant of Robert Merton's (1974)
option-pricing model to derive the probability of default for a given
company. Thanks very much for your help!!

The VBA code is as follows:


Option Explicit
Option Base 1

Sub MonteCarlo()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Debug.Print "Beginning Loop" & vbTab & Format(Now, "nn:ss")


Worksheets("Control").Range("D9:D11").Clear
Worksheets("Control").Range("C9:C11").Select
Selection.Copy
Worksheets("Control").Range("D9:D11").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone,
_
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False

Worksheets("Control").Range("starttime") = Time
Worksheets("Control").Range("starttime").NumberFormat = "dd:hh:mm:ss"

Dim NumberOfRuns As Integer
Dim NumberOfTrials As Integer
Dim NumberOfFirms As Integer

NumberOfRuns = Worksheets("Control").Range("D1").Value
NumberOfTrials = Worksheets("Control").Range("D2").Value

'Need to set the number of firms in a manual manner!!
NumberOfFirms = 1000

Dim i As Integer
Dim j As Integer
Dim k As Integer


Dim InputData As Range, arrayInputData As Variant
Dim OutputData As Range, arrayOutputData As Variant

Set InputData = Worksheets("InputDataSheet").Range("C3:G1002")
arrayInputData = InputData

Set OutputData = Worksheets("OutputDataSheet").Range("C3:C1002")
arrayOutputData = InputData

'Dim Plot As Range
'Set Plot = Worksheets("Sheet4").Range("B1:K10")

Dim RandomNumbers, AssetValue, AssetValueChange, RawDefault,
CumulativeRawDefault, Default, CumulativeDefault, DefaultRate
ReDim RandomNumbers(1 To NumberOfFirms, 1 To NumberOfRuns)
As Double

ReDim AssetValue(1 To NumberOfFirms, 0 To NumberOfRuns) As
Double
ReDim AssetValueChange(1 To NumberOfFirms, 1 To
NumberOfRuns) As Double

ReDim DefaultPoint(1 To NumberOfFirms, 0 To NumberOfRuns) As
Double
ReDim AssetVolatility(1 To NumberOfFirms, 0 To NumberOfRuns)
As Double
ReDim DriftROA(1 To NumberOfFirms, 0 To NumberOfRuns) As
Double
ReDim DividendYield(1 To NumberOfFirms, 0 To NumberOfRuns)
As Double
ReDim TimeIncrement(1 To NumberOfFirms, 0 To NumberOfRuns)
As Double

ReDim RawDefault(1 To NumberOfFirms, 1 To NumberOfRuns) As
Double
ReDim CumulativeRawDefault(1 To NumberOfFirms, 0 To
NumberOfRuns) As Double

ReDim Default(1 To NumberOfFirms, 1 To NumberOfTrials) As
Double
ReDim CumulativeDefault(1 To NumberOfFirms, 0 To
NumberOfTrials) As Double

ReDim DefaultRate(1 To NumberOfFirms) As Single





For k = 1 To NumberOfTrials

Randomize
For i = 1 To NumberOfFirms
For j = 1 To NumberOfRuns
RandomNumbers(i, j) = Rnd()

AssetValue(i, 0) = arrayInputData(i, 1)
DefaultPoint(i, 0) = arrayInputData(i, 2)
AssetVolatility(i, 0) = arrayInputData(i, 3)
DriftROA(i, 0) = arrayInputData(i, 4)
DividendYield(i, 0) = arrayInputData(i, 5)
TimeIncrement(i, 0) = 1 / NumberOfRuns

CumulativeRawDefault(i, 0) = 0

DefaultPoint(i, j) = DefaultPoint(i, 0)
DriftROA(i, j) = DriftROA(i, 0)
DividendYield(i, j) = DividendYield(i, 0)
AssetVolatility(i, j) = AssetVolatility(i, 0)
TimeIncrement(i, j) = TimeIncrement(i, 0)
Next j
Next i


For i = 1 To NumberOfFirms
For j = 1 To NumberOfRuns
AssetValueChange(i, j) = Application.NormInv(RandomNumbers
(i, j), (DriftROA(i, j) - DividendYield(i, j)) * AssetValue(i, j -
1) * TimeIncrement(i, j), AssetVolatility(i, j) * AssetValue(i, j -
1) * Sqr(TimeIncrement(i, j)))
AssetValue(i, j) = AssetValue(i, j - 1) + AssetValueChange
(i, j)

If AssetValue(i, j) < DefaultPoint(i, j) Then
RawDefault(i, j) = 1
Else
RawDefault(i, j) = 0
End If

CumulativeRawDefault(i, j) = CumulativeRawDefault(i, j - 1)
+ RawDefault(i, j)

Next j
Next i


For i = 1 To NumberOfFirms
If CumulativeRawDefault(i, NumberOfRuns) > 0 Then
Default(i, k) = 1
Else
Default(i, k) = 0
End If
Next i



Worksheets("Control").Range("elapsed") = Time - Worksheets
("Control").Range("starttime")
Range("elapsed").NumberFormat = "dd:hh:mm:ss"

Worksheets("Control").Range("D20") = k


Next k


For i = 1 To NumberOfFirms
CumulativeDefault(i, 0) = 0
Next i

For i = 1 To NumberOfFirms
For k = 1 To NumberOfTrials
CumulativeDefault(i, k) = CumulativeDefault(i, k - 1) +
Default(i, k)
Next k
Next i

For i = 1 To NumberOfFirms
DefaultRate(i) = CumulativeDefault(i, NumberOfTrials) /
NumberOfTrials
Next i

For i = 1 To NumberOfFirms
arrayOutputData(i, 1) = DefaultRate(i)
Next i


Worksheets("Control").Range("stoptime") = Time
Worksheets("Control").Range("stoptime").NumberFormat = "dd:hh:mm:ss"

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End With
End Sub