michael ogunbiyi
asked on
VBA - Montecarlo simulation issues
i have the following script which works for 100 simulations.
i would actually like user to define number of simulations on spreadsheet using a form when the simulation is activated.
the code is as follows:
thanks
i would actually like user to define number of simulations on spreadsheet using a form when the simulation is activated.
the code is as follows:
Sub MCSIM()
'
' MCSIM Macro
'Montecarlo simulation
'
Dim vs() As Variant
ReDim vs(100, 2)
Dim wbpg(6) As Object
Dim vshtnames
Set shtppe = ThisWorkbook.Worksheets("Portfolio Projections_Extended")
Set shtsmy = ThisWorkbook.Worksheets("Results Summary")
Set shtdt = ThisWorkbook.Worksheets("Data")
Set sht2wk = ThisWorkbook.Worksheets("2wk Returns")
Set shtst = ThisWorkbook.Worksheets("Stress Testing")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
PricingFile = [Pricing_File].Value
If [LUD].Value < Date Then frmPricingFile.Show
If Dir(PricingFile) = "" Then
ans = MsgBox("The Daily Pricing File cannot be found. Do you wish to continue?", vbYesNo, "Daily Pricing Update")
If ans = vbNo Then GoTo CleanUp
Else
Set wb = Workbooks.Add(PricingFile)
Set wks = wb.Worksheets("Daily Prices")
With wks
.Range(.Range("A2"), .Range("A2").End(xlToRight).End(xlDown)).Copy
shtdt.Range("A7").PasteSpecial xlPasteValues
End With
wb.Close
Set wks = Nothing
Set wb = Nothing
[Pricing_File].Value = PricingFile
[LUD].Value = Date
End If
'wbfullpath = "D:\Documents\CSL_FCAM Risk assessment\Limit setting\VaRResults_CurrentDay.xlsx"
wbfullpath = ThisWorkbook.Path & "\VaRResults_" & Format(Date, "ddmmyyyy") & ".xlsx"
If Dir(wbfullpath) <> "" And [Prompt_Overwrite].Value = "Y" Then
ans = MsgBox(wbfullpath & " already exists. Do you wish to overwrite the exisiting file?", vbYesNo, "File Found")
If ans = vbNo Then
MsgBox "Please rename your file and re-start this process"
GoTo CleanUp
ElseIf ans = vbYes Then
Kill wbfullpath
End If
End If
'Update Daily Prices
starttime = Timer
msg = "Running Monte Carlo Simulation"
frmRun.lblmsg.Caption = msg
frmRun.Show False
With shtppe
For i = 0 To 99
msg = msg & "."
frmRun.lblmsg.Caption = msg
frmRun.Repaint
Application.Calculate
vs(i, 0) = .Range("J2").Value
vs(i, 1) = .Range("J3").Value
Next i
.Range("MC_Start").Resize(100, 2).Value = vs
End With
endtime = Timer
'msg = msg & Chr(10) & "Random generator Complete - " & (endtime - starttime) & " seconds"
'frmRun.lblmsg.Caption = msg
'Results summary creation - copy and paste volatility results for Equally wieghted and EWMA Volatility
msg = msg & Chr(10) & "Creating Results Summary"
frmRun.lblmsg.Caption = msg
frmRun.Repaint
'// Copy Stddevs from Data Sheet
With shtdt
.Range(.Range("StDev_Start").Offset(-1, 0), .Range("StDev_Start").End(xlToRight)).Copy
End With
shtsmy.Range("C15").PasteSpecial xlPasteValues, Transpose:=True
With shtdt
.Range(.Range("Vol_Start"), .Range("Vol_Start").End(xlToRight)).Copy
shtsmy.Range("E15").PasteSpecial xlPasteValues, Transpose:=True
.Range(.Range("wvol_Start"), .Range("wvol_Start").End(xlDown)).Copy
shtsmy.Range("H15").PasteSpecial xlPasteValues
.Range(.Range("Asset_Start"), .Range("Asset_Start").End(xlToRight)).Copy
shtsmy.Range("C15").PasteSpecial xlPasteValues, Transpose:=True
.Range(.Range("Stdev_Start"), .Range("Stdev_Start").End(xlToRight)).Copy
shtsmy.Range("D15").PasteSpecial xlPasteValues, Transpose:=True
End With
With sht2wk
.Range(.Range("twowk_Start"), .Range("twowk_Start").Offset(0, 1).End(xlToRight).End(xlDown)).Copy
shtsmy.Range("C68").PasteSpecial xlPasteValues, Transpose:=True
End With
'Exit Sub
'Report Creation
'Create "Results Summary" in new work book - VaRResults_Current day.xls
msg = msg & Chr(10) & "Creating VaRResults Report for " & Format(Date, "dd/mm/yyyy")
frmRun.lblmsg.Caption = msg
frmRun.Repaint
Set wb = Workbooks.Add
wb.SaveAs Filename:=wbfullpath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
vshtnames = Array("", "Results Summary", "Returns & Volatility Comp", "Historical VAR&Vola_Standalone", "EWMA Variance&Vola", "Daily Prices", "Stressed VaR")
For n = 1 To 5
With wb.Worksheets
If n > 1 Then
Set wbpg(n) = .Add(After:=wbpg(n - 1))
wbpg(n).Name = vshtnames(n)
Else
Set wbpg(n) = .Add
wbpg(n).Name = vshtnames(n)
For k = wb.Worksheets.Count To 1 Step -1
If wb.Worksheets(k).Name <> vshtnames(n) Then wb.Worksheets(k).Delete
Next k
End If
End With
Next n
msg = msg & Chr(10) & "Creating Historical returns"
frmRun.lblmsg.Caption = msg
frmRun.Repaint
'Create Historical Returns Report in newly created work book
shtsmy.Range("vPage1").Copy
With wbpg(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
wb.Activate
wbpg(1).UsedRange.Columns.AutoFit
ActiveWindow.DisplayGridlines = False
With wbpg(1)
.Columns(1).Rows.AutoFit
.Rows("1:1").RowHeight = 75
End With
ThisWorkbook.Activate
shtsmy.Range("vPage2").Copy
With wbpg(2).Range("A2")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
wb.Activate
wbpg(2).UsedRange.Columns.AutoFit
ActiveWindow.DisplayGridlines = False
With wbpg(2)
.Columns(1).Rows.AutoFit
.Rows("1:1").RowHeight = 75
End With
ThisWorkbook.Activate
msg = msg & Chr(10) & "Creating Historical VaR & Volatility Report"
frmRun.lblmsg.Caption = msg
frmRun.Repaint
'Historical VaR&Vola report
With shtdt
.Range(.Range("vPage3_Start"), .Range("vPage3_Start").Offset(0, 3).End(xlToRight).End(xlDown)).Copy
End With
With wbpg(3).Range("A3")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
With shtdt
.Range(.Range("stdev_Start").Offset(0, -1), .Range("stdev_Start").End(xlToRight)).Copy
End With
With wbpg(3).Range("B2")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
wb.Activate
With wbpg(3)
.Columns(1).Columns.AutoFit
.Columns(1).Rows.AutoFit
.Rows("1:1").RowHeight = 75
shtdt.Shapes("txtCorrMatrix").Copy
.Paste .Cells(1, 4)
End With
ActiveWindow.DisplayGridlines = False
ThisWorkbook.Activate
msg = msg & Chr(10) & "Creating EWMA Variance & Volatility Report"
frmRun.lblmsg.Caption = msg
frmRun.Repaint
'EWMA_Variance & Vola Report
'***** Variance & Volatility *****"
With shtdt
.Range(.Range("stdev_Start").Offset(2, 0), .Range("stdev_Start").End(xlToRight).Offset(4, 0)).Copy
End With
With wbpg(4).Range("A3")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
With shtdt
.Range(.Range("wvol_Start").Offset(-1, 0), .Range("wvol_Start").End(xlDown)).Copy
End With
With wbpg(4).Range("A8")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
shtdt.Range("PTable").Copy
With wbpg(4).Range("D8")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
wb.Activate
ActiveWindow.DisplayGridlines = False
With wbpg(4)
.Rows("1:1").RowHeight = 75
shtdt.Shapes("txtEWMA").Copy
.Paste .Cells(1, 4)
End With
ThisWorkbook.Activate
'Daily Prices
msg = msg & Chr(10) & "Creating Daily Prices Report"
frmRun.lblmsg.Caption = msg
frmRun.Repaint
With shtdt
.Range(.Range("Asset_Start").Offset(-1, 0), .Range("Asset_Start").Offset(3, 0).End(xlToRight).End(xlDown)).Copy
End With
With wbpg(5).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
wb.Activate
ActiveWindow.DisplayGridlines = False
With wbpg(5)
.Rows("1:1").RowHeight = 75
shtdt.Shapes("txtPricing").Copy
.Paste .Cells(1, 4)
End With
ThisWorkbook.Activate
'Stressed Var
msg = msg & Chr(10) & "Creating Stress Testing Report"
frmRun.lblmsg.Caption = msg
frmRun.Repaint
shtst.Copy After:=wbpg(5)
Set wbpg(6) = wb.Worksheets(shtst.Name)
With wbpg(6)
.Activate
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With
wb.Save
wb.Close
CleanUp:
Set shtppe = Nothing
Set shtsmy = Nothing
Set shtdt = Nothing
Set sht2wk = Nothing
Set shtst = Nothing
Set wb = Nothing
Erase vs
Erase wbpg
Erase vshtnames
endtime = Timer
frmRun.lblmsg.Caption = "Daily Report Complete - " & (endtime - starttime) & " seconds"
'frmRun.Hide
End Sub
thanks
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.