Hi There,

I`ve been modeling in VBA to create a simulation model which I want to analyze using a Monte Carlo simulation. However, to run this script 1000 of times cost a lot of time. Does any one of you know how to speed up the code or perhaps has an alternative method?

I`ve posted key parts of the code below:


Sub Run_MC()

Dim q As Integer
Dim start_time, end_time
start_time = Now()

Application.StatusBar = True           ' stond op true

Reset_MCResults

For q = 1 To Cells(3, 3)

    'Application.StatusBar = "Processing Run " & q
   
    Reset_Values

    Create_random_seeds_demand
    Create_random_seeds_forecast
    Create_random_seeds_leadtime
 
    Simulate_step
    
    Application.ScreenUpdating = False
    
    Copy_MCResults
    
    'Sheets("Results").Select                                'copies CFR results
    'Sheets("Results").Cells(46, 7).Select
    'Selection.Copy
    'Sheets("Results").Cells(100, 3 + q).Select
    'Selection.PasteSpecial PAste:=xlPasteValues
    
    
Next q

Create_FreqChart
Application.ScreenUpdating = True
end_time = Now()
MsgBox (DateDiff("s", start_time, end_time))



Sub Create_random_seeds_demand()

Dim Last_column As Integer

Last_column = Sheets("Environment model").Cells(11, 5) + 5

Sheets("Environment model").Cells(14, 6).Formula = "=RAND()"                                'insert formula for 1 cell
Sheets("Environment model").Cells(14, 6).Copy                                               'copy formula
Sheets("Environment model").Range(Cells(14, 6), Cells(14, Last_column)).PasteSpecial PAste:=xlPasteFormulas
Calculate                                                       'calculate formula for whole row
Selection.Copy
Selection.PasteSpecial PAste:=xlPasteValues                     'Values are copy-pasted again to prevent changes during analysis

End Sub

Sub Simulate_step()

Dim MaxRun As Integer
Dim LeadTime As Integer
Dim MaxMCstep As Integer
Dim CurrentMCstep As Integer

Max_Run = Sheets("Environment model").Range("Max_Run")
LeadTime = Sheets("Environment model").Range("LeadTime")
MaxMCstep = Sheets("Environment model").Cells(3, 3)

Application.ScreenUpdating = False
Application.Cursor = xlWait
Application.DisplayStatusBar = True

CurrentDay = Sheets("Environment model").Range("CurrentDay") + LTError       ' THIS RESETS THE LTerror VALUE!!! each time you click...

If Sheets("Environment model").Range("Run_option") = "Single_step" Then
    If CurrentDay <= 0 Then
        Set_SS_Strategy
    End If
            
        Run_OneStep
        
        Sheets("Environment model").Cells(60, 6 + CurrentDay) = "X"
        ' create something to indicate expected delivery date
        'CurrentDay = Range("CurrentDay")
        LTError = Sheets("Environment model").Cells(43, 6 + CurrentDay)                             'retrieves the LT Error
        CurrentDay = Sheets("Environment model").Range("CurrentDay") + LTError                      'adds LT error to planning
        Calculate_CurrentDFC
    Else
        
    Set_SS_Strategy
    CurrentDay = Sheets("Environment model").Range("CurrentDay") + LTError
        
        While CurrentDay <= Max_Run - LeadTime
            CurrentMCstep = Sheets("Environment model").Cells(3, 4)
            Application.StatusBar = "Percentage MC Run completed: " & (CurrentMCstep / MaxMCstep * 100) & "%, Processing day " & CurrentDay
            Run_OneStep
            Sheets("Environment model").Cells(60, 6 + CurrentDay) = "X"
            LTError = Sheets("Environment model").Cells(43, 6 + CurrentDay)                             'retrieves the LT Error
            CurrentDay = Sheets("Environment model").Range("CurrentDay") + LTError                      'adds LT error to planning
        Wend
    CalculateAllDFC
    End If

Application.StatusBar = False
Application.Cursor = xlDefault

End Sub


Sub Run_OneStep()

Dim PlannedDelivery As Integer
Dim ActualDelivery As Integer
Dim TargetLeadTime As Integer
Dim RowReplenishmentPlanning As Integer
Dim RowActualReplenishment As Integer


'CurrentDay = Range("CurrentDay")
TargetLeadTime = Sheets("Environment model").Range("LeadTime")
RowReplenishmentPlanning = 39
RowActualReplenishment = 65

PlannedDelivery = 6 + CurrentDay + TargetLeadTime
ActualDelivery = 6 + CurrentDay + TargetLeadTime                ' HAS TO BE FINISHED

' Copies Replenishment with MOQ to Actual Replenishments
If Sheets("Environment model").Cells(RowReplenishmentPlanning, PlannedDelivery) <> "" Then
    Sheets("Environment model").Cells(RowReplenishmentPlanning, PlannedDelivery).Copy
    Sheets("Environment model").Cells(RowActualReplenishment, PlannedDelivery).PasteSpecial PAste:=xlPasteValues
    End If

End Sub


Sub Reset_Values()

Range("Range_days").ClearContents
Range("Range_DFC").ClearContents
Range("PlannedOrders").ClearContents
CurrentDay = 0
Sheets("Environment model").Cells(60, 5 + CurrentDay) = "X"



End Sub

Sub Copy_MCResults()

Dim Runnumber As Integer
Dim Numb_MC_Res As Integer

Runnumber = Sheets("Results").Range("Numb_Runs")

Numb_MC_Res = Sheets("Results").Range("Numb_MC_Results")

    Application.ScreenUpdating = False
    
                                                                                               'copies CFR results
    Sheets("Results").Range(Sheets("Results").Cells(48, 7), Sheets("Results").Cells(47 + Numb_MC_Res, 7)).Copy
    Sheets("Results").Range("Range_to_copy_towards").PasteSpecial PAste:=xlPasteValues         'Range(Cells(100, 3 + Runnumber), Cells(103, 3 + Runnumber)).Select
    
    Sheets("Results").Range(Sheets("Results").Cells(5, 200), Sheets("Results").Cells(30, 409)).Copy                                'copies intermediate results
    Sheets("Results").Range(Sheets("Results").Cells(5 + ((Runnumber + 1) * 28), 200), Sheets("Results").Cells(30 + ((Runnumber + 1) * 28), 409)).PasteSpecial PAste:=xlPasteValues
    
    If Cells(117, 2) = 1 Then
        Sheets("Results").Range("D123:D329").Copy                           'Copies results to be worked with
        Sheets("Results").Range("E123:E329").PasteSpecial PAste:=xlPasteValues
    ElseIf Cells(117, 2) = 2 Then
        Sheets("Results").Range("AJ123:AJ329").Copy
        Sheets("Results").Range("AK123:AK329").PasteSpecial PAste:=xlPasteValues
    ElseIf Cells(117, 2) = 3 Then
        Sheets("Results").Range("AS123:AS329").Copy
        Sheets("Results").Range("AT123:AT329").PasteSpecial PAste:=xlPasteValues
    ElseIf Cells(117, 2) = 4 Then
        Sheets("Results").Range("AW123:AW432").Copy
        Sheets("Results").Range("AX123:AX432").PasteSpecial PAste:=xlPasteValues
    Else
    End If


End Sub

Sub CalculateAllDFC()

Dim InventoryLeft As Single
Dim DFC As Single

Dim Counter As Integer
Dim RowDemand As Integer
Dim RowClosedInventory As Integer
Dim RowDFC As Integer
Dim CurrentDay As Integer
Dim Today As Integer
Dim MaxRun As Integer
Dim LongTermAvg As Integer
Dim MaxMCstep As Integer
Dim CurrentMCstep As Integer

RowDemand = 64
RowClosedInventory = 66
RowDFC = 69

CurrentDay = Sheets("Environment model").Range("CurrentDay")
Today = 5 + Sheets("Environment model").Range("CurrentDay")                                 'Refers to "TODAY"-column
Max_Run = Sheets("Environment model").Range("Max_Run")                                      'Counts last simulation day
LongTermAvg = Sheets("Environment model").Range("LongTermAvg")
MaxMCstep = Cells(3, 3)

    For Today = 5 To Max_Run
        CurrentMCstep = Sheets("Environment model").Cells(3, 4)
        Application.StatusBar = "Percentage MC Run completed: " & (CurrentMCstep / MaxMCstep * 100) & "%, Processing DFC " & Today
        InventoryLeft = Sheets("Environment model").Cells(RowClosedInventory, Today)
        
        Counter = Today + 1                                                      'Incremental counter for columns after today
        DFC = 0                                                                  'Counts the DFC

        InventoryLeft = Sheets("Environment model").Cells(RowClosedInventory, Today)

        If (LeftInv <= LongTermAvg / 100000) Then                                'LeftInv is almost always bigger than long term avg / 10000? WHAT HAPPENS HERE?
                Sheets("Environment model").Cells(RowDFC, Today) = DFC                                       'Resets the value of the DFC(current day) to zero
             Else
        End If

        While InventoryLeft >= Sheets("Environment model").Cells(RowDemand, Counter) And Counter <= Max_Run  ' Add max for last column!!!!
            InventoryLeft = InventoryLeft - Sheets("Environment model").Cells(RowDemand, Counter)            ' Virtual calculates Inventory left after subtracting forecasted demand of 1 day
                 DFC = DFC + 1                                                   ' Adds one 'full' day to the DFC
            Counter = Counter + 1                                                ' Adds 1 to counter to look one day further
        Wend

        If Counter <= Max_Run Then
            DFC = DFC + (InventoryLeft / Cells(RowDemand, Counter))         ' Calculates and adds remnant to DFC counter, if it is not beyond last day
        ElseIf LongTermAvg = 0 Then                                         'if it IS last day, and longtermAvg=0, than set DFC to 99
            DFC = 99
        Else
            DFC = DFC + InventoryLeft / LongTermAvg                       'if it IS last day and longtermAvg<>0, calculate remnant
        End If

        Sheets("Environment model").Cells(RowDFC, Today) = DFC                             ' Prints DFC value add current day`s cell

    Next Today

End Sub
Many thanks!