How can I speed up my VBA simulation??

[Andy]

Hi all

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!!

Kind Regards,

Andy

The VBA codes are as follows:


Option Explicit
Option Base 1

Sub MonteCarlo()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Worksheets("Control").Range("D911").Clear
Worksheets("Control").Range("C9:C11").Select
Selection.Copy
Worksheets("Control").Range("D911").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
Dim OutputData As Range

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

'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


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


For k = 1 To NumberOfTrials

For i = 1 To NumberOfFirms
AssetValue(i, 0) = InputData.Cells(i, 1).Value
DefaultPoint(i, 0) = InputData.Cells(i, 2).Value
AssetVolatility(i, 0) = InputData.Cells(i, 3).Value
DriftROA(i, 0) = InputData.Cells(i, 4).Value
DividendYield(i, 0) = InputData.Cells(i, 5).Value
TimeIncrement(i, 0) = 1 / NumberOfRuns
Next i


For i = 1 To NumberOfFirms
For j = 1 To NumberOfRuns
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)
Next j
Next i


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

For i = 1 To NumberOfFirms
For j = 1 To NumberOfRuns
If AssetValue(i, j) < DefaultPoint(i, j) Then
RawDefault(i, j) = 1
Else
RawDefault(i, j) = 0
End If
Next j
Next i


For i = 1 To NumberOfFirms
For j = 1 To NumberOfRuns
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
OutputData.Cells(i, 1) = DefaultRate(i)
Next i


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

Application.Calculation = xlCalculationAutomatic

End With
End Sub

 

[Niek Otten]

Multiple Dims don't work that way.

This:

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

Will Dim RandomNumbers as double and all the others as Variant.

I wouldn't be surprised if changing just that increases your speed
sufficiently

 

[Niek Otten]

Sorry, should have read further; probably the ReDimming corrects this

 

[Gman]

I think there's a number of things you can do. An overview:

(1) Avoid looping through and making multiple read/writes to the
worksheet - use arrays instead. Example at foot of post. I think this is
most relevant to you and will drastically improve performance. I would
wager that if you do this you'll probably see a %50 or more reduction in
time to run.

(2) Every time you update the worksheet (for each of your writes, Excel
is updating the screen. Stop this with Application.ScreenUpdating =
False at the top of your code and then Application.ScreenUpdating = True
at the bottom. HANG ON - YOU'VE ALREADY DONE THIS HAVEN'T YOU.
APOLOGIES! (I'll leave this line in anyway as a general comment.)

(3) You may have other events firing in your Excel instance every time
you update a sheet. Make (careful) use of Application.EnableEvents =
False/True when making a write to prevent this. Be careful to always
switch it back on.

(4) There's no need to select and clear/copy ranges e.g.

Worksheets("Control").Range("D911").Clear
Worksheets("Control").Range("C9:C11").Select
Selection.Copy
Worksheets("Control").Range("D911").Select
etc.

Just to it directly as in:
Worksheets("Control").Range("D911").Value = _
Worksheets("Control").Range("C9:C11").Value
or even
With worksheets("Control")
.Range("D911").Value = .Range("C9:C11").Value
end with

Although since you don't do this often it won't really be hitting
performance.

(5) Place some code in your procedure like:
Debug.Print "Beginning Loop A" & vbtab & format(now, "nn:ss")
This will help you realise where the major bottlenecks are.

(6) Use With / End With when addressing the same object repeatedly e.g.
not:
For i = 1 To NumberOfFirms
AssetValue(i, 0) = InputData.Cells(i, 1).Value
Next i
but:
With InputData
For i = 1 To NumberOfFirms
AssetValue(i, 0) = .Cells(i, 1).Value
Next i
End with
(Example only.... I would use arrays anyway in this instance...)

(7) Update the Application.StatusBar at verious stages in the
procedure. OK - it won't speed things up but it at least shows you it's
doing something so might make it seem faster! Set to False at the
procedure end.


Back to point 1... Writing to and reading from the spreadsheet multiple
times can often *really* slow things down. I've done comparisons in the
past and been amazed at the results.

I wouldn't be bothered about the "one-offs" like:

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

But things like:
For i = 1 To NumberOfFirms
AssetValue(i, 0) = InputData.Cells(i, 1).Value
DefaultPoint(i, 0) = InputData.Cells(i, 2).Value
AssetVolatility(i, 0) = InputData.Cells(i, 3).Value
DriftROA(i, 0) = InputData.Cells(i, 4).Value
DividendYield(i, 0) = InputData.Cells(i, 5).Value
TimeIncrement(i, 0) = 1 / NumberOfRuns
Next i

involve 5000 separate reads which will definitely take a while.

I would load everything into an array and loop through that instead - I
think you'll be surprised at how much quicker it is.

For example, this isn't exactly how I would do it but as a quick amendment:

Dim InputData As Range, arrInputData as Variant
Dim OutputData As Range, arrOutputData as Variant

Set InputData = Worksheets("InputDataSheet").Range("C3:G1002")
'Load the entire range into an array
arrInputData = InputData
Set OutputData = Worksheets("OutputDataSheet").Range("C3:C1002")
Outputdata.clear
arrOutputData = OutputData 'a lazy way of dimensioning
'the output array

'then, in your loop, read the array rather than the worksheet
For i = 1 To NumberOfFirms
AssetValue(i, 0) = arrInputData(i, 1)
DefaultPoint(i, 0) = arrInputData(i, 2)
AssetVolatility(i, 0) = arrInputData(i, 3)
DriftROA(i, 0) = arrInputData(i, 4)
DividendYield(i, 0) = arrInputData(i, 5)
TimeIncrement(i, 0) = 1 / NumberOfRuns
Next i


When you need to write back to the worksheet you should do something like:

'load up the output into our output array
For i = 1 To NumberOfFirms
arrOutputData (i, 1) = DefaultRate(i)
Next i
'Write all your data back in one fell swoop rather than piecemeal.
OutputData = arrOutputData

That's about it. I hope this helps.

Gman

 

[Gman]

As a caveat to my <you'll probably see a %50 or more reduction in time
to run> claim.

That goes only for the sections where you're reading to and from the
worksheet. Obviously it won't affect things like:

For i = 1 To NumberOfFirms
For j = 1 To NumberOfRuns
If AssetValue(i, j) < DefaultPoint(i, j) Then
RawDefault(i, j) = 1
Else
RawDefault(i, j) = 0
End If
Next j
Next i


Depending on the NumberOfRuns this could of course take an age. If you
want to hone the code mathematically.... I ain't your man!