Мой код VBA работает нормально, но иногда возникают проблемы при запуске. Я обычно начинаю код с F5 или щелкаю по зеленому стартовому треугольнику, и у меня есть счетчик для наблюдения, плюс он «активирует» новые листы по мере их продвижения. Сначала это обычно начинается нормально. Но иногда кажется, что он не работает. Когда я выхожу наружу, кажется, что он сбежал, но счетчики и новые «активированные» листы не состоялись. Когда я «ломаю» и «сбрасываю» пару раз, а затем снова запускаю, кажется, что он работает нормально.
Любая помощь?
Я вижу, что должен был опубликовать свой код (извините, Я новичок в этом). Вот оно:
Option Explicit
Sub ReorgData()
'Define variables as Double, Integer, or Strings
Dim LOMIN As Double, LOMAX As Double, LBMIN As Double, LBMAX As Double
Dim LHMIN As Double, LHMAX As Double, LSMIN As Double, LSMAX As Double
Dim LO As Double, LB As Double, LH As Double, LS As Double
Dim O As Double, B As Double, H As Double, S As Double, LOG As Double
Dim O1 As Double, O2 As Double, O3 As Double, O4 As Double
Dim B1 As Double, B2 As Double, B3 As Double, B4 As Double, Nend As Integer
Dim H1 As Double, H2 As Double, H3 As Double, H4 As Double, SLOG As Double
Dim S1 As Double, S2 As Double, S2Log As Double, SSS As Double, SP As Double, S2P As Double
Dim HShape As Double, HRate As Double, HMean As Double, HSD As Double
Dim OMean As Double, OSD As Double, BMean As Double, BSD As Double, SMean As Double, SSD As Double
Dim x As Double, Time As Double, sht As Double, re As Double, converge As Double
Dim OSY2 As Double, bsy2 As Double, hsy2 As Double, ssy2 As Double
Dim alpha As Double, beta As Double, xxx As Integer, vartest As Double, test As Double
Dim N As Integer, NO As Integer, NH As Integer, NS As Integer, NB As Integer, z As Integer
Dim GAMMA_Inv As Double, a As Double, Nerr As Integer, NN As Integer
Dim Lognorm_Inv As Double, ActiveWorkbook As Double, etest As Double, ztest As Double
Dim MAXO As Double, MAXB As Double, MAXH As Double, MAXS As Double
Dim Report As String
' To allow the M-C to run quickly, most of the post processing is done in the
' "Monte Carlo Results.xlsx" spreadsheet. It is openned automatically at the end
' of the M-C run but the address needs to be specified
'Worksheets("Sheet2").Activate
' Set up error catching. On error, action is sent to "eh" at the end of the code
' but the progam will continue to run with errors written to Sheet1
NN = 19
Nerr = 0
On Error GoTo eh
' Write Labels
ThisWorkbook.Worksheets("sheet1").Cells(4, 1) = "# Runs"
ThisWorkbook.Worksheets("sheet1").Cells(2, 1) = "MODELS"
ThisWorkbook.Worksheets("sheet1").Cells(2, 2) = "Obenour"
ThisWorkbook.Worksheets("sheet1").Cells(2, 3) = "Bertani"
ThisWorkbook.Worksheets("sheet1").Cells(2, 4) = " Ho"
ThisWorkbook.Worksheets("sheet1").Cells(2, 5) = "Stumpf"
ThisWorkbook.Worksheets("sheet1").Cells(2, 7) = "Obenour"
ThisWorkbook.Worksheets("sheet1").Cells(2, 8) = "Bertani"
ThisWorkbook.Worksheets("sheet1").Cells(2, 9) = " Ho"
ThisWorkbook.Worksheets("sheet1").Cells(2, 10) = "Stumpf"
ThisWorkbook.Worksheets("sheet1").Cells(2, 12) = "Obenour"
ThisWorkbook.Worksheets("sheet1").Cells(2, 13) = "Bertani"
ThisWorkbook.Worksheets("sheet1").Cells(2, 14) = " Ho"
ThisWorkbook.Worksheets("sheet1").Cells(2, 15) = "Stumpf"
ThisWorkbook.Worksheets("sheet1").Cells(3, 1) = "Max cut (3%)"
ThisWorkbook.Worksheets("sheet1").Cells(5, 1) = "Max HAB"
ThisWorkbook.Worksheets("sheet1").Cells(6, 1) = "Fixed Loads"
ThisWorkbook.Worksheets("sheet1").Cells(7, 1) = "Model Parameters"
ThisWorkbook.Worksheets("sheet1").Cells(8, 1) = "p1"
ThisWorkbook.Worksheets("sheet1").Cells(9, 1) = "p2"
ThisWorkbook.Worksheets("sheet1").Cells(10, 1) = "p3"
ThisWorkbook.Worksheets("sheet1").Cells(11, 1) = "p4"
ThisWorkbook.Worksheets("sheet1").Cells(12, 1) = "Load parameters"
ThisWorkbook.Worksheets("sheet1").Cells(13, 1) = "Gamma Shape"
ThisWorkbook.Worksheets("sheet1").Cells(14, 1) = "Gamma Rate"
ThisWorkbook.Worksheets("sheet1").Cells(15, 1) = "Full Gamma Shape"
ThisWorkbook.Worksheets("sheet1").Cells(16, 1) = "Full Gamma Rate"
ThisWorkbook.Worksheets("sheet1").Cells(18, 1) = "O & B Time"
'Assigne max loads and max HAB from Sheet1
LOMAX = ThisWorkbook.Worksheets("sheet1").Cells(3, 2)
LBMAX = ThisWorkbook.Worksheets("sheet1").Cells(3, 3)
LHMAX = ThisWorkbook.Worksheets("sheet1").Cells(3, 4)
LSMAX = ThisWorkbook.Worksheets("sheet1").Cells(3, 5)
MAXO = ThisWorkbook.Worksheets("sheet1").Cells(5, 2)
MAXB = ThisWorkbook.Worksheets("sheet1").Cells(5, 3)
MAXH = ThisWorkbook.Worksheets("sheet1").Cells(5, 4)
MAXS = ThisWorkbook.Worksheets("sheet1").Cells(5, 5)
ThisWorkbook.Worksheets("sheet1").Range("a19:M20000").Clear
For sht = 1 To 8
' Code runs through all of the cases:
' Sheet1 is the "Deterministic Models and Fixed Loads"
' Sheet2 is the "Fixed Loads and Probablistic Model"
' Sheet3 is the "Deterministic Models and Uncertain Loads"
' Sheet4 is the "Uncertain Loads and Probablistic Models"
' Sheet5 is the "Fixed Loads and Probablistic Model with Prediction Error"
' Sheet6 is the "Uncertain Loads and Probablistic Models with Prediction Error"
' Sheet7 is the "Full Uncertain Loads and Probablistic Models with Prediction Error"
' At this point Sheet7 has the same load functions as Sheet6. It will be replaced
' withthe functions for the 3 SWAT models
' Sheet8 is the "Uncertain SWAT Loads and Deterministic Models"
' At this point Sheet8 has the same load functions as Sheet6. It will be replaced
' with the functions for the 3 SWAT models
'
' Sheet Loads Model
' 1 Fixed Fixed
' 2 Fixed Uncertain
' 3 Uncertain Fixed
' 4 Uncertain Uncertain
' 5 Fixed Uncertain with Prediction Error
' 6 Uncertain Uncertain with Prediction Error
' 7 Uncertain SWAT Uncertain with Prediction Error
' 8 Uncertain SWAT Fixed
'
'Reset random number to the same seed for each sht
Randomize (3669)
'Worksheets(sht).Activate
' Clear sheets and set formats
ThisWorkbook.Worksheets(sht).Range("g2:o100000").Clear
Worksheets(sht).Columns("G:J"). _
NumberFormat = "###0.;[Red](#,##0.00)"
Worksheets(sht).Columns("L:O"). _
NumberFormat = "###0.0;[Red](#,##0.0)"
Worksheets("Sheet1").Range("A20:I10000"). _
NumberFormat = "###0.000;[Red](#,##0.0)"
' Write Sheet-specific labels
ThisWorkbook.Worksheets(sht).Cells(1, 16) = sht
ThisWorkbook.Worksheets("sheet1").Cells(1, 1) = "Fixed Loads / Fixed Models"
ThisWorkbook.Worksheets("Sheet5").Cells(1, 1) = "Fixed Loads / Uncertain Model with Error"
ThisWorkbook.Worksheets("Sheet3").Cells(1, 1) = "Uncertain Loads / Fixed Models"
ThisWorkbook.Worksheets("Sheet6").Cells(1, 1) = "Uncertain Loads / Uncertain Models with Error"
ThisWorkbook.Worksheets("sheet2").Cells(1, 1) = "Fixed Loads / Uncertain Model"
ThisWorkbook.Worksheets("sheet4").Cells(1, 1) = "Uncertain Loads / Uncertain Models"
ThisWorkbook.Worksheets("Sheet7").Cells(1, 1) = "Full Uncertain Loads / Uncertain Models with Error"
ThisWorkbook.Worksheets("sheet8").Cells(1, 1) = "Full Uncertain Loads / Fixed Model"
ThisWorkbook.Worksheets(sht).Cells(1, 7) = "Obenour"
ThisWorkbook.Worksheets(sht).Cells(1, 8) = "Bertani"
ThisWorkbook.Worksheets(sht).Cells(1, 9) = " Ho"
ThisWorkbook.Worksheets(sht).Cells(1, 10) = "Stumpf"
ThisWorkbook.Worksheets(sht).Cells(1, 12) = "Obenour"
ThisWorkbook.Worksheets(sht).Cells(1, 13) = "Bertani"
ThisWorkbook.Worksheets(sht).Cells(1, 14) = " Ho"
ThisWorkbook.Worksheets(sht).Cells(1, 15) = "Stumpf"
'Initialize counters
NO = 1
NB = 1
NH = 1
NS = 1
'Monte Carlo Runs
For N = 3 To Cells(4, 2)
ThisWorkbook.Worksheets("Sheet1").Cells(4, 3) = sht
ThisWorkbook.Worksheets("sheet1").Cells(4, 4) = N
'Initialize Fixed CENTRAL TENDENCY Loads from Sheet1
LO = ThisWorkbook.Worksheets("sheet1").Cells(6, 2)
LB = ThisWorkbook.Worksheets("sheet1").Cells(6, 3)
LH = ThisWorkbook.Worksheets("sheet1").Cells(6, 4)
LS = ThisWorkbook.Worksheets("sheet1").Cells(6, 5)
' LS = LO * 1000
' LO = LS / 1000
'Initialize Fixed Determinisitic Parameters from Sheet1
O1 = ThisWorkbook.Worksheets("sheet1").Cells(8, 2)
O2 = ThisWorkbook.Worksheets("sheet1").Cells(9, 2)
O3 = ThisWorkbook.Worksheets("sheet1").Cells(10, 2)
O4 = ThisWorkbook.Worksheets("sheet1").Cells(11, 2)
B1 = ThisWorkbook.Worksheets("sheet1").Cells(8, 3)
B2 = ThisWorkbook.Worksheets("sheet1").Cells(9, 3)
B3 = ThisWorkbook.Worksheets("sheet1").Cells(10, 3)
B4 = ThisWorkbook.Worksheets("sheet1").Cells(11, 3)
H1 = ThisWorkbook.Worksheets("sheet1").Cells(8, 4)
H2 = ThisWorkbook.Worksheets("sheet1").Cells(9, 4)
H3 = ThisWorkbook.Worksheets("sheet1").Cells(10, 4)
S1 = ThisWorkbook.Worksheets("sheet1").Cells(8, 5)
S2 = ThisWorkbook.Worksheets("sheet1").Cells(9, 5)
'________________________________________________________
'For cases with uncertain loads
'Get loads from GAMMA DISTRIBUTIONS
'The following are for the original SWAT model output
'The Shape and Rate arguments for original SWAT model are from lines 13 and 14 on Sheet1
'The Shape and Rate agruments for the 3 SWAT models are from lines 15 and 16 on Sheet1
If sht = 3 Or sht = 4 Or sht = 6 Or sht = 7 Or sht = 8 Then
If sht = 7 Or sht = 8 Then
HRate = ThisWorkbook.Worksheets("sheet1").Cells(16, 2)
HShape = ThisWorkbook.Worksheets("sheet1").Cells(15, 2)
Else
HRate = ThisWorkbook.Worksheets("sheet1").Cells(14, 2)
HShape = ThisWorkbook.Worksheets("sheet1").Cells(13, 2)
End If
Report = "Obenour-8"
LO = WorksheetFunction.GAMMA_Inv(Rnd, HShape, HRate)
If sht = 7 Or sht = 8 Then
HRate = ThisWorkbook.Worksheets("sheet1").Cells(16, 3)
HShape = ThisWorkbook.Worksheets("sheet1").Cells(15, 3)
Else
HRate = ThisWorkbook.Worksheets("sheet1").Cells(14, 3)
HShape = ThisWorkbook.Worksheets("sheet1").Cells(13, 3)
End If
Report = "Bertani-8"
LB = WorksheetFunction.GAMMA_Inv(Rnd, HShape, HRate)
If sht = 7 Or sht = 8 Then
HRate = ThisWorkbook.Worksheets("sheet1").Cells(16, 4)
HShape = ThisWorkbook.Worksheets("sheet1").Cells(15, 4)
Else
HRate = ThisWorkbook.Worksheets("sheet1").Cells(14, 4)
HShape = ThisWorkbook.Worksheets("sheet1").Cells(13, 4)
End If
Report = "Ho-8"
LH = WorksheetFunction.GAMMA_Inv(Rnd, HShape, HRate)
If sht = 7 Or sht = 8 Then
HRate = ThisWorkbook.Worksheets("sheet1").Cells(16, 5)
HShape = ThisWorkbook.Worksheets("sheet1").Cells(15, 5)
Else
HRate = ThisWorkbook.Worksheets("sheet1").Cells(14, 5)
HShape = ThisWorkbook.Worksheets("sheet1").Cells(13, 5)
End If
Report = "Stumpf-8"
LS = WorksheetFunction.GAMMA_Inv(Rnd, HShape, HRate)
' LS = LO * 1000
' LO = LS / 1000
End If
'_________________________________________________________
'For cases with uncertain model parameters
'Get PARAMETERS AND Sy2 FROM POSTERIOR DISTRIBUTIONS
If sht = 2 Or sht = 4 Or sht = 5 Or sht = 6 Or sht = 7 Then
' The following code selects parameters and Sy2 values from the same posterior row
' To be more random, we could recalculate z before each draw
' Posterior distributions for each model are in the sheets with their names
z = Int(995 - 2 + 1) * Rnd + 2
O1 = ThisWorkbook.Sheets("Obenour").Cells(z + 1, 2).Value
O2 = ThisWorkbook.Sheets("Obenour").Cells(z + 1, 3).Value
O3 = ThisWorkbook.Sheets("Obenour").Cells(z + 1, 4).Value
O4 = ThisWorkbook.Sheets("Obenour").Cells(z + 1, 5).Value
OSY2 = ThisWorkbook.Sheets("Obenour").Cells(z + 1, 7).Value
B1 = ThisWorkbook.Sheets("Bertani").Cells(z + 1, 2).Value
B2 = ThisWorkbook.Sheets("Bertani").Cells(z + 1, 3).Value
B3 = ThisWorkbook.Sheets("Bertani").Cells(z + 1, 4).Value
B4 = ThisWorkbook.Sheets("Bertani").Cells(z + 1, 5).Value
bsy2 = ThisWorkbook.Sheets("Bertani").Cells(z + 1, 7).Value
H1 = ThisWorkbook.Sheets("Ho").Cells(z + 1, 2).Value
H2 = ThisWorkbook.Sheets("Ho").Cells(z + 1, 3).Value
H3 = ThisWorkbook.Sheets("Ho").Cells(z + 1, 4).Value
hsy2 = ThisWorkbook.Worksheets("Ho").Cells(z + 1, 5).Value
'note these are the parameters for Stumpf log-tranformed model
S1 = ThisWorkbook.Sheets("Stumpf").Cells(z + 1, 2).Value
S2 = ThisWorkbook.Sheets("Stumpf").Cells(z + 1, 3).Value
ssy2 = ThisWorkbook.Worksheets("Stumpf").Cells(z + 1, 4).Value
Else
End If
'______________________________________________________________
'Calculate DETERMINISTIC HAB forecasts (Zhat)for cases where the load
' is below the truncation (e.g., LOMAX)
'For Obenour, Bertani, and Ho, there is a 0.75 extent floor
'Obneour and Bertani TIME is from Cell(18,3)
Time = Cells(18, 2)
'Obenour Model
If LO < LOMAX Then
If (O1 + O2 * LO + O4 * Time < 0) Then
O = O3
Else: O = O3 + O1 + O2 * LO + O4 * Time
End If
Else
End If
If O < 0.75 Then O = 0.75
'Bertani Model
If LB < LBMAX Then
If (B1 + B2 * LB + B4 * Time < 0) Then
B = B3
Else: B = B3 + B1 + B2 * LB + B4 * Time
End If
Else
End If
If B < 0.75 Then B = 0.75
'Ho Model with 9-year cumulative load from Cell(11,4)
If LH < LHMAX Then
H = H1 + H2 * LH + H3 * Cells(11, 4)
Else
End If
If H < 0.75 Then H = 0.75
'Stumpf Log-transformed Modelmodel
If LS < LSMAX Then
SP = S2 + S1 * LS
'Convert to non-transformed value
S = 10 ^ SP
Else
End If
'_______________________________________________________________________
'Write results IF LOADS ARE BELOW TRUNCTION VALUES and HAB EXTENT IS BELOW MAXx from Sheet1.
' The cut-off was because rare combinations of parameter values and loads resulted
' in extremely high values.
If sht < 5 Or sht = 8 Then
If (LO < LOMAX And O < MAXO) Then
NO = NO + 1
ThisWorkbook.Worksheets(sht).Cells(NO, 7) = LO * 1000
ThisWorkbook.Worksheets(sht).Cells(NO, 12) = O
' ThisWorkbook.Worksheets(sht).Cells(2, 17) = N
Else
End If
If (LB < LBMAX And B < MAXB) Then
NB = NB + 1
ThisWorkbook.Worksheets(sht).Cells(NB, 8) = LB * 1000
ThisWorkbook.Worksheets(sht).Cells(NB, 13) = B
' ThisWorkbook.Worksheets(sht).Cells(2, 17) = N
Else
End If
If (LH < LHMAX And H < MAXH) Then
NH = NH + 1
ThisWorkbook.Worksheets(sht).Cells(NH, 9) = LH
ThisWorkbook.Worksheets(sht).Cells(NH, 14) = H
' ThisWorkbook.Worksheets(sht).Cells(2, 17) = N
Else
End If
If (LS < LSMAX And S < MAXS) Then
NS = NS + 1
ThisWorkbook.Worksheets(sht).Cells(NS, 10) = LS
ThisWorkbook.Worksheets(sht).Cells(NS, 15) = S
' ThisWorkbook.Worksheets(sht).Cells(2, 17) = N
Else
End If
'___________________________________________________________
'Skip out of Monte Carlo if Fixed Loads and Parameters
If sht = 1 Then GoTo SKIP
'___________________________________________________________
Else
'Include PREDICTION Error for Probablistic model cases 5, 6, and 7
'Write results IF LOADS ARE BELOW TRUNCTION VALUES and HAB EXTENT IS BELOW MAXx
'Obenour
alpha = O * O * OSY2 ^ -2
beta = OSY2 * OSY2 / O
If (LO < LOMAX And O < MAXO) Then
NO = NO + 1
Report = "Obenour-7"
O = WorksheetFunction.GAMMA_Inv(Rnd, alpha, beta)
ThisWorkbook.Worksheets(sht).Cells(NO, 7) = LO * 1000
ThisWorkbook.Worksheets(sht).Cells(NO, 12) = O
' ThisWorkbook.Worksheets(sht).Cells(2, 17) = N
Else
End If
'Bertani
alpha = B * B * bsy2 ^ -2
beta = bsy2 * bsy2 / B
If (LB < LBMAX And B < MAXB) Then
Report = "Bertani-7"
NB = NB + 1
B = WorksheetFunction.GAMMA_Inv(Rnd, alpha, beta)
ThisWorkbook.Worksheets(sht).Cells(NB, 8) = LB * 1000
ThisWorkbook.Worksheets(sht).Cells(NB, 13) = B
' ThisWorkbook.Worksheets(sht).Cells(2, 17) = N
Else
End If
'Ho
alpha = H * H * hsy2 ^ -2
beta = hsy2 * hsy2 / H
If (LH < LHMAX And H < MAXH) Then
NH = NH + 1
Report = "Ho-7"
H = WorksheetFunction.GAMMA_Inv(Rnd, alpha, beta)
ThisWorkbook.Worksheets(sht).Cells(NH, 9) = LH
ThisWorkbook.Worksheets(sht).Cells(NH, 14) = H
' ThisWorkbook.Worksheets(sht).Cells(2, 17) = N
Else
End If
'Stumpf
Report = "Stumpf-7"
re = WorksheetFunction.Norm_Inv(Rnd, 0, ssy2)
SP = SP + re
S = 10 ^ SP
If (LS < LSMAX And S < MAXS) Then
NS = NS + 1
ThisWorkbook.Worksheets(sht).Cells(NS, 10) = LS
ThisWorkbook.Worksheets(sht).Cells(NS, 15) = S
' ThisWorkbook.Worksheets(sht).Cells(2, 17) = N
Else
End If
End If
'_______________________________________________________
Next N
SKIP:
'Write number of cases used for each model
ThisWorkbook.Worksheets(sht).Cells(2, 21) = NS
ThisWorkbook.Worksheets(sht).Cells(2, 20) = NH
ThisWorkbook.Worksheets(sht).Cells(2, 19) = NB
ThisWorkbook.Worksheets(sht).Cells(2, 18) = NO
Next sht
'Open analysis workbook. Requires full address
Workbooks.Open "C:\Users\scavia\Box Sync\Current Folders\C\Analysis\Monte Carlo\Revised Future Monte Carlo Results.xlsx"
'Workbooks.Open "C:\Users\scavia\Box Sync\Current Folders\C\Analysis\monte Carlo\Future Monte Carlo Variance Tests.xlsx"
'________________________________________________________
' Error handling
' Write error on Sheet1 but continue processing
5000
Done:
Exit Sub
eh:
Nerr = Nerr + 1
NN = NN + 1
ThisWorkbook.Worksheets("sheet1").Cells(19, 1) = "Sheet"
ThisWorkbook.Worksheets("sheet1").Cells(19, 2) = "Error"
ThisWorkbook.Worksheets("sheet1").Cells(19, 3) = "Model"
ThisWorkbook.Worksheets("sheet1").Cells(19, 4) = "alpha"
ThisWorkbook.Worksheets("sheet1").Cells(19, 5) = "beta"
'ThisWorkbook.Worksheets("sheet1").Cells(19, 6) = "HShape"
'ThisWorkbook.Worksheets("sheet1").Cells(19, 7) = "HRate"
'ThisWorkbook.Worksheets("sheet1").Cells(19, 8) = "re"
ThisWorkbook.Worksheets("sheet1").Cells(19, 9) = "Rnd"
ThisWorkbook.Worksheets("sheet1").Cells(NN, 2) = Err.Description
ThisWorkbook.Worksheets("sheet1").Cells(NN, 1) = sht
ThisWorkbook.Worksheets("sheet1").Cells(NN, 3) = Report
ThisWorkbook.Worksheets("sheet1").Cells(NN, 4) = alpha
ThisWorkbook.Worksheets("sheet1").Cells(NN, 5) = beta
'ThisWorkbook.Worksheets("sheet1").Cells(NN, 6) = HShape
'ThisWorkbook.Worksheets("sheet1").Cells(NN, 7) = HRate
'ThisWorkbook.Worksheets("sheet1").Cells(NN, 8) = re
ThisWorkbook.Worksheets("sheet1").Cells(NN, 9) = Rnd
Resume Next
'____________________________________________________________
End Sub