Split the function

Split the function

i have this function: 

Sub STOCHRUN()
    Range("NOW").Select
    Selection.Copy
    Range("START").Select
    ActiveSheet.Paste
    Sheets("Summary").Select
    Columns("H:IV").Select
    Selection.EntireColumn.Delete
    Range("A1").Select
    Range("WPSW").Select
    ActiveCell.value = 1
'
    Dim NSR As Integer
    Dim N1 As Integer
    Dim N2 As Integer

    NSR = 3
    N1 = NSR + 1
    N2 = NSR + 2
    
'
' INSERT THESE TO AVE AND STDEV RESPECTIVELY
    For I = 1 To NSR
    Call APSMRUN
    Call CopySimResults
    Calculate
    Next
    
    Range("I2").Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(0, 2).Range("A1").Select
    ActiveCell.FormulaR1C1 = "Means"
    ActiveCell.Offset(0, 1).Range("A1").Select
    ActiveCell.FormulaR1C1 = "StDev"
    ActiveCell.Offset(3, -1).Range("A1").Select
' Change to N1
    ActiveCell.FormulaR1C1 = "=AVERAGE(RC[-4]:RC[-2])"
    ActiveCell.Offset(0, 1).Range("A1").Select
'
' Change to N2
    ActiveCell.FormulaR1C1 = "=STDEV(RC[-5]:RC[-3])"
    ActiveCell.Offset(0, -1).Range("A1:B1").Select
    Selection.NumberFormat = "0.0"
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1:A1000").Select
    ActiveSheet.Paste
    Range("WPSW").Select
    ActiveCell.value = 0

'   Record End Time of Run
    Range("NOW").Select
    Selection.Copy
    Range("END").Select
    ActiveSheet.Paste
    SIMELAPSED = Application.Range("ELAPSED")
    MsgBox "Stochastic Simulation Runs Completed, " & SIMELAPSED & " ELAPSED "
    Range("DATERUN").Select
    Selection.Copy
    Range("RUNDATE").Select
    ActiveSheet.Paste
    Sheets("Summary").Select
End Sub

Since running this function causes the server to timeout.  At the line where CALL APSMRUN is found will the error be shown. Is there a way to split this function?