VBA - Montecarlo simulation issues

michael ogunbiyi
michael ogunbiyi used Ask the Experts™
on
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:

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

Open in new window


thanks
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
IT / Software Engineering Consultant
Top Expert 2016
Commented:
Give this a try:

Sub MCSIM()
'
' MCSIM Macro
'Montecarlo simulation
'

Dim vs() As Variant
Dim wbpg(6) As Object
Dim vshtnames

Dim simCount As Long
simCount = Application.InputBox("Please specify the number of simulations:", "Simulation Count", 100, , , , , 1)
ReDim vs(simCount, 2)

 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 simCount - 1
        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(simCount, 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

Open in new window


»bp

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial