PDA

View Full Version : Urgent help needed - "Runtime error 9: subscript out of range"



lostman
07-29-2018, 08:22 AM
Hi all,

I am currently finishing my master thesis including simulations and have run into an issue.

I am running simulations through a "Monte Carlo" macro that was imported from another work book. After each run I receive the error message "Runtime error 9: subscript out of range". When I try to debug the following is showed, with the highlighted error area in the second row of:
wb.Sheets(number_of_formulas * 2 + 1).Delete



Option Explicit


' MonteCarlito - www.montecarlito.com
' Martin Auer, 2005
' Distributed under terms of GNU General Public License


Sub simulate()
Dim sel As Range
Set sel = Application.Selection
If sel.Cells.Columns.Count < 2 Or sel.Cells.Rows.Count < 2 Then
MsgBox "You need to select a rectangular region, with the number of trials in the upper left cell, with the simulation formulas in the rest of the upper row, and with some cells selected beneath."
Exit Sub
End If

Dim sel_tmp As Range
Dim create_histogram As Boolean
create_histogram = False
If sel.Cells(1, 1).Font.Bold = True Then
create_histogram = True
End If

Dim number_of_formulas As Long
Dim number_of_trials As Long
Dim number_of_outputrows As Long
Dim runs() As Variant
Dim i As Long
Dim j As Long
Dim tmp() As Variant
Dim high_speed As Boolean
high_speed = False

number_of_formulas = sel.Cells.Columns.Count - 1
number_of_trials = sel.Cells(1, 1)
number_of_outputrows = sel.Cells.Rows.Count - 1

Dim mean_values() As Variant
Dim var_values() As Variant
Dim stddev_values() As Variant
Dim stderr_values() As Variant
Dim max_values() As Variant
Dim min_values() As Variant
Dim median_values() As Variant
Dim skew_values() As Variant
Dim kurt_values() As Variant

ReDim mean_values(number_of_formulas)
ReDim var_values(number_of_formulas)
ReDim stddev_values(number_of_formulas)
ReDim stderr_values(number_of_formulas)
ReDim max_values(number_of_formulas)
ReDim min_values(number_of_formulas)
ReDim median_values(number_of_formulas)
ReDim skew_values(number_of_formulas)
ReDim kurt_values(number_of_formulas)

If number_of_trials = 0 Then
MsgBox "Put the number of trials in the upper left cell of your selection. If it is negative, simulation is run in high-speed-mode with minimized windows."
Exit Sub
End If
If number_of_trials < 0 Then
number_of_trials = Math.Abs(number_of_trials)
high_speed = True
End If

ReDim runs(number_of_formulas, number_of_trials)
ReDim tmp(number_of_trials)


' Run simulation
If high_speed = True Then Application.Visible = False
For i = 1 To number_of_trials
Application.Calculate
For j = 1 To number_of_formulas
runs(j, i) = sel.Cells(1, 1 + j)
Next j
If high_speed = False And (i Mod 10 = 0 Or i = number_of_trials) Then
sel.Cells(1, 1) = i
End If
Next i
If high_speed = True Then Application.Visible = True

' Calculate statistics
For i = 1 To number_of_formulas
Call arrcpy(runs, tmp, i, number_of_trials)
mean_values(i) = mean(tmp)
stddev_values(i) = stddev(tmp)
stderr_values(i) = stddev_values(i) / Math.Sqr(number_of_trials)
var_values(i) = stddev_values(i) * stddev_values(i)
skew_values(i) = skewness(tmp)
kurt_values(i) = kurtosis(tmp)

median_values(i) = mmedian(tmp)
Next i

' Output
For i = 1 To number_of_outputrows
If i = 1 Then
sel.Cells(1 + i, 1) = "Mean"
Call out(1 + i, 2, mean_values(), sel)
ElseIf i = 2 Then
sel.Cells(1 + i, 1) = "Standard error"
Call out(1 + i, 2, stderr_values(), sel)
ElseIf i = 3 Then
sel.Cells(1 + i, 1) = "Median"
Call out(1 + i, 2, median_values(), sel)
ElseIf i = 4 Then
sel.Cells(1 + i, 1) = "Standard deviation"
Call out(1 + i, 2, stddev_values(), sel)
ElseIf i = 5 Then
sel.Cells(1 + i, 1) = "Variance"
Call out(1 + i, 2, var_values(), sel)
ElseIf i = 6 Then
sel.Cells(1 + i, 1) = "Skewness"
Call out(1 + i, 2, skew_values(), sel)
ElseIf i = 7 Then
sel.Cells(1 + i, 1) = "Kurtosis"
Call out(1 + i, 2, kurt_values(), sel)


End If
Next i

' Create histograms
If create_histogram = True Then
Dim wb As Workbook
Set wb = Workbooks.Add

Dim lmin As Variant
Dim lmax As Variant
Dim interval As Variant
Dim i_tmp As Long

For i = number_of_formulas To 1 Step -1
Dim hist(50) As Variant
Dim ws As Worksheet
Set ws = wb.Sheets.Add
ws.Name = CStr(i)

Call arrcpy(runs, tmp, i, number_of_trials)

lmin = min(tmp)
lmax = max(tmp)
lmax = lmax + 1 / 1000 * (lmax - lmin)
interval = (lmax - lmin) / 50

Erase hist
For j = 1 To number_of_trials
i_tmp = CLng((tmp(j) - lmin) / interval - 0.5)
hist(i_tmp + 1) = hist(i_tmp + 1) + 1
Next j

For j = 1 To UBound(hist)
ws.Cells(j, 1) = lmin + (j - 1) * interval
ws.Cells(j, 2) = hist(j)
Next j

Dim r1 As Range
Dim r2 As Range
Set r1 = Range("A1", "A50")
Set r2 = Range("B1", "B50")

Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=r2, PlotBy:=xlColumns
ActiveChart.Name = "Diagram " + CStr(i)
ActiveChart.SeriesCollection(1).XValues = r1
With ActiveChart.ChartGroups(1)
.GapWidth = 0
End With
Next i
Application.DisplayAlerts = False
wb.Sheets(number_of_formulas * 2 + 1).Delete
wb.Sheets(number_of_formulas * 2 + 1).Delete
wb.Sheets(number_of_formulas * 2 + 1).Delete
Application.DisplayAlerts = True
End If
End Sub


Sub arrcpy(ByRef a() As Variant, ByRef b() As Variant, i As Long, uj As Long)
Dim j As Long
For j = 1 To uj
b(j) = a(i, j)
Next j
End Sub


Function mmedian(a() As Variant) As Variant
Call QuickSort(a)
Dim i As Long
i = CLng(UBound(a) / 2)
mmedian = a(i)
End Function


Function min(a() As Variant) As Variant
Dim i As Long
min = a(1)
For i = 1 To UBound(a)
If a(i) < min Then min = a(i)
Next i
End Function


Function max(a() As Variant) As Variant
Dim i As Long
max = a(1)
For i = 1 To UBound(a)
If a(i) > max Then max = a(i)
Next i
End Function


Function mean(a() As Variant) As Variant

Since I am not familiar with VBA and need to proceed with my master thesis which builds on this simulation I need your help urgently.

Please let me know if you need more information to help me solving this issue.


Thank you in advance.


Best,
Lukas

Kenneth Hobs
07-29-2018, 08:57 AM
Welcome to the forum!

I don't know what 2nd row means. If deleting a sheet is the problem, then you should check IF the sheet exists before deleting. e.g.

Sub Test_WorkSheetExists()
MsgBox "WorksheetExists? " & WorkSheetExists("Sheet1"), _
vbInformation, "ActiveWorkbook.ActiveSheet"

MsgBox "WorksheetExists? " & WorkSheetExists("ken", "ken.xlsm"), _
vbInformation
End Sub


'WorkSheetExists in a workbook:
Function WorkSheetExists(sWorkSheet As String, Optional sWorkbook As String = "") As Boolean
Dim ws As Worksheet, wb As Workbook
On Error GoTo notExists
If sWorkbook = "" Then
Set wb = ActiveWorkbook
Else
Set wb = Workbooks(sWorkbook) 'sWorkbook must be open already. e.g. ken.xlsm, not x:\ken.xlsm.
End If
Set ws = wb.Worksheets(sWorkSheet)
WorkSheetExists = True
Exit Function
notExists:
WorkSheetExists = False
End Function

Fluff
07-29-2018, 09:00 AM
X post
https://www.excelforum.com/excel-programming-vba-macros/1239781-urgent-help-needed-runtime-error-9-subscript-out-of-range.html

offthelip
07-29-2018, 09:09 AM
I suggest that you delete all three lines with that code in them. All they are doing is deleting a worksheet to do some tidying up. However It appears to me that the indexing is wrong because you create the worksheets in a loop:

For i = number_of_formulas To 1 Step -1 Dim hist(50) As Variant
Dim ws As Worksheet
Set ws = wb.Sheets.Add
ws.Name = CStr(i)

Which will create a worksheet with numbers 1 to whatever the number "number_of_formulas" is. For example if this number is three you get sheet 1 , 2 and 3. However when you get to the delete statements they are trying to delete a sheet with index 2*"number_of_formulas" +1 whic would be 7 in this example , that index doesn't exist so you get the message
You can delete the sheet manually after you have finshed if you want to.

lostman
07-29-2018, 09:19 AM
Many thanks!

"The Runtime error 9: subscript out of range" disappeared when I deleted the suggested lines.

However, after each run/simulation a new work book is opened with histograms which is not the case when running the macro in the original work book. Is this something related to what you mentioned in your comment about the loop? How would you suggest me solving that issue? I do not want histograms opening after each run.

Thank you in advance.

Kenneth Hobs
07-29-2018, 12:17 PM
If you don't want to create them then unbold A1 or delete that first IF() that checks for bold. You can then delete that last IF loop as well.

lostman
07-29-2018, 12:59 PM
It worked just fine. Many thanks Kenneth!