Run Time Error 91

[Aussiebear]

I have tried to establish a custom menu by borrowing the layout from J-Walk's Menumaker and using the following section of code

Sub CreateMenu()
Dim MenuSheet As Worksheet
Dim MenuObject As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As CommandBarButton
Dim Row As Integer
Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceID

' Location for Menu Data
Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")

' Make sure the menus aren't duplicated
Call DeleteMenu

'Initialize the row counter
Row = 2

'Add the menus, menu items and sub menu items using data stored on MenuSheet

Do Until IsEmpty(MenuSheet.Cells(Row, 1))
With MenuSheet
MenuLevel = .Cells(Row, 1)
Caption = .Cells(Row, 2)
PositionOrMacro = .Cells(Row, 3)
Divider = .Cells(Row, 4)
FaceID = .Cells(Row, 5)
NextLevel = .Cells(Row - 1, 1)
End With

Select Case MenuLevel

Case 1 ' A Menu
'Add the top level meu to the worksheet commandBar
Set MenuObject = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _
Before:=PositionOrMacro, Temporary:=True)
MenuObject.Caption = Caption

Case 2 ' A Menu item
If NextLevel = 3 Then
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
Else
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
MenuItem.OnAction = PositionOrMacro
End If
MenuItem.Caption = Caption
If FaceID <> "" Then SubMenuItem.FaceID = FaceID
If Divider Then SubMenuItem.BeginGroup = True

Case 3 ' A SubMenu Item
Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuItem.Caption = Caption
SubMenuItem.OnAction = PositionOrMacro
If FaceID <> "" Then SubMenuItem.FaceID = FaceID
If Divider Then SubMenuItem.BeginGroup = True
End Select
Row = Row + 1

Loop
End Sub

Sub DeleteMenu()

Dim MenuSheet As Worksheet
Dim Row As Integer
Dim Caption As String

On Error Resume Next
Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
Row = 2
Do Until IsEmpty(MenuSheet.Cells(Row, 1))
If MenuSheet.Cells(Row, 1) = 1 Then
Caption = MenuSheet.Cells(Row, 2)
Application.CommandBars(1).Controls(Caption).Delete
End If
Row = Row + 1
Loop
On Error GoTo 0
End Sub

Sub DummyMacro()
MsgBox "This is a do nothing Macro."
End Sub

Sub About()
frmDetails.Show
End Sub



The run time error message appears on opening the workbook, yet when I bring up the vbe environment and choose Debug/Compile project, there are no errors highlighted. What have I done wrong?

The menu sheet named Menusheet is included below to show what I was attempting.

[Aussiebear]

When going to help, I'm told that I've either:

a) Attempted to use an object variable that isn't yet referencing a valid object, or
b) You attempted to use an object variable that has not been set to Nothing.

[XLGibbs]

Do you have a MakeSD procedure yet? It is on your macro list, but if the macro doesn't exist..it will error on trying to build the menu.

If you want the debugger to point to the right spot..comment out the "On Error Resume Next" lines and it will highlight offensive commands.

[Aussiebear]

Thank you, Ghost who codes....

[XLGibbs]

I ain't the ghost, that be firefytr.

[Aussiebear]

The MakeSD sub is in module 1;


Option Explicit

Const gsTitle As String = "Make a Sample Dispatch Sheet"
Const gsVer As String = "Ver 1.0, 15/05/2007"
Const gsPassword As String = "Shona"

Private wbSD As Workbook
Private wsSDH As Worksheet
Private wsSD As Worksheet
Private rWhiteboard As Range

Sub MakeSD()
Const sVerify As String = "Do you really want to create a sample dispatch?"

'On Error GoTo MakeSD_exit

If MsgBox(sVerify, vbQuestion + vbOKCancel, gsTitle & " (" & gsVer & ")") = vbOK Then

Application.ScreenUpdating = False

Call TaskInitialise

Call ExtractWhiteboardData

Call SortExtractedData(wsSD)

Call CopyDataOver

wbSD.Close savechanges:=False

wsSDH.Copy

End If

MakeSD_exit:
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub


Private Sub TaskInitialise()
Dim wbGSRT As Workbook
Dim wsWhiteboard As Worksheet
Dim i As Long
Set wbGSRT = ThisWorkbook
Set wsWhiteboard = wbGSRT.Worksheets("Whiteboard")
Set wsSDH = wbGSRT.Worksheets("Sample Dispatch")

Set wbSD = Workbooks.Add
Set wsSD = wbSD.Worksheets(1)

'Look for data to move
Call wsWhiteboard.Unprotect(gsPassword)
Set rWhiteboard = wsWhiteboard.Cells(1, 1).CurrentRegion
Call wsWhiteboard.Protect(gsPassword)
Set rWhiteboard = rWhiteboard.Cells(2, 1).Resize(rWhiteboard.Rows.Count - 1, rWhiteboard.Columns.Count)
For i = 7 To 56 Step 7
wsSDH.Cells(i, "B").Resize(5, 6).ClearContents
Next i
End Sub

Private Sub ExtractWhiteboardData()
Dim iSD As Long
Dim iWhiteboard As Long
Dim rRow As Range

iSD = 1
For Each rRow In rWhiteboard.EntireRow.Rows

With rRow

For iWhiteboard = 10 To 20 Step 2
'See if it needs to be sent
If (Trim(.Cells(1, iWhiteboard).Value) = "Y" And _
Trim(.Cells(1, iWhiteboard + 1).Value) = "") Then

'Create temp sort/break field
wsSD.Cells(iSD, "A").Value = .Cells(1, "G").Value

'Add test Size to Vendor Test Number
Select Case iWhiteboard
Case 10
wsSD.Cells(iSD, "C").Value = .Cells(1, "B").Value & "-01"
wsSD.Cells(iSD, "A").Value = wsSD.Cells(iSD, "A").Value & "-A"
Case 12
wsSD.Cells(iSD, "C").Value = .Cells(1, "B").Value & "-250"
wsSD.Cells(iSD, "A").Value = wsSD.Cells(iSD, "A").Value & "-B"
Case 14
wsSD.Cells(iSD, "C").Value = .Cells(1, "B").Value & "-500"
wsSD.Cells(iSD, "A").Value = wsSD.Cells(iSD, "A").Value & "-C"
Case 16
wsSD.Cells(iSD, "C").Value = .Cells(1, "B").Value & "-1000"
wsSD.Cells(iSD, "A").Value = wsSD.Cells(iSD, "A").Value & "-D"
Case 18
wsSD.Cells(iSD, "C").Value = .Cells(1, "B").Value & "-1500"
wsSD.Cells(iSD, "A").Value = wsSD.Cells(iSD, "A").Value & "-E"
Case 20
wsSD.Cells(iSD, "C").Value = .Cells(1, "B").Value & "-2000"
wsSD.Cells(iSD, "A").Value = wsSD.Cells(iSD, "A").Value & "-F"
End Select

'add Vendor Details
wsSD.Cells(iSD, "D").Value = .Cells(1, 3).Value
wsSD.Cells(iSD, "E").Value = .Cells(1, 4).Value

'Add Bucket Number
wsSD.Cells(iSD, "F").Value = .Cells(1, "A").Value

'Translate Grain Code to Grain Name
Select Case .Cells(1, "G").Value
Case "B"
wsSD.Cells(iSD, "G").Value = "Barley"
Case "C"
wsSD.Cells(iSD, "G").Value = "Corn"
Case "S"
wsSD.Cells(iSD, "G").Value = "Sorghum"
Case "T"
wsSD.Cells(iSD, "G").Value = "Triticale"
Case "W"
wsSD.Cells(iSD, "G").Value = "Wheat"
End Select

'Get the task Number from the Vendor Dec Number
wsSD.Cells(iSD, "B").Value = "'" & Right(wsSD.Cells(iSD, "C").Value, _
Len(wsSD.Cells(iSD, "C").Value) - InStrRev(wsSD.Cells(iSD, "C").Value, "-"))

'Increment row counter
iSD = iSD + 1
End If

Next iWhiteboard
End With
Next
End Sub

Private Sub SortExtractedData(ByRef Sh As Worksheet)
'Sort SD by Commodity and by Company
Sh.Cells.Sort Key1:=Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub

Private Sub CopyDataOver()
Dim iFive As Long
Dim iSD As Long
Dim iSDH As Long
Dim rSD As Range
Dim sLastGrain As String
Dim sLastTask As String
Dim iDispatch As Long
Dim iComp As Long

Do
iComp = InputBox("Supply the Next Comp Number")
Loop Until iComp > 0
Do
iDispatch = InputBox("and the next Dispatch Number is?")
Loop Until iDispatch > 0

iFive = 1
iSDH = 7
Set rSD = wsSD.Cells(1, 1).CurrentRegion

With rSD

sLastGrain = .Range("A1").Value
sLastTask = .Range("B1").Value
wsSDH.Range("C3").Value = Format(Date, "dd/mm/yyyy")
wsSDH.Range("C4").Value = iComp
wsSDH.Cells(iSDH, "B").Value = iDispatch
For iSD = 1 To .Rows.Count


'Look for changes of grain type, task Number, or bucket max
If (.Cells(iSD, "A").Value <> sLastGrain Or _
.Cells(iSD, "B").Value <> sLastTask Or _
iFive > 5) Then

iFive = 1
sLastGrain = .Cells(iSD, 1).Value
sLastTask = .Cells(iSD, "B").Value
iSDH = iSDH + 7 - iSDH Mod 7
iDispatch = iDispatch + 1
wsSDH.Cells(iSDH, "B").Value = iDispatch
End If

.Cells(iSD, 3).Resize(1, 5).Copy
wsSDH.Cells(iSDH, "C").Resize(1, 5).PasteSpecial xlPasteValues
iSDH = iSDH + 1
iFive = iFive + 1

Next iSD
End With
End Sub


Which worked fine before I added the MenuSheet and its data. In fact I can run this macro from the F5 key.

The custom menu works to the poiint of allowing me to navigate to a particular sheet. It doesn't pick up any of the other options. So I'm guessing that the error occurs after the navigation section

[Bob Phillips]

Option Explicit

Sub CreateMenu()
Dim MenuSheet As Worksheet
Dim MenuObject As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As CommandBarButton
Dim Row As Integer
Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceID

' Location for Menu Data
Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")

' Make sure the menus aren't duplicated
Call DeleteMenu

'Initialize the row counter
Row = 2

'Add the menus, menu items and sub menu items using data stored on MenuSheet

Do Until IsEmpty(MenuSheet.Cells(Row, 1))
With MenuSheet
MenuLevel = .Cells(Row, 1)
Caption = .Cells(Row, 2)
PositionOrMacro = .Cells(Row, 3)
Divider = .Cells(Row, 4)
FaceID = .Cells(Row, 5)
NextLevel = .Cells(Row + 1, 1)
End With

Select Case MenuLevel

Case 1 ' A Menu
'Add the top level meu to the worksheet commandBar
Set MenuObject = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _
Before:=PositionOrMacro, Temporary:=True)
MenuObject.Caption = Caption

Case 2 ' A Menu item
If NextLevel = 3 Then
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
Else
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
MenuItem.OnAction = PositionOrMacro
End If
MenuItem.Caption = Caption
If FaceID <> "" Then MenuItem.FaceID = FaceID
If Divider Then MenuItem.BeginGroup = True

Case 3 ' A SubMenu Item
Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuItem.Caption = Caption
SubMenuItem.OnAction = PositionOrMacro
If FaceID <> "" Then SubMenuItem.FaceID = FaceID
If Divider Then SubMenuItem.BeginGroup = True
End Select
Row = Row + 1

Loop
End Sub

Sub DeleteMenu()

Dim MenuSheet As Worksheet
Dim Row As Integer
Dim Caption As String

On Error Resume Next
Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
Row = 2
Do Until IsEmpty(MenuSheet.Cells(Row, 1))
If MenuSheet.Cells(Row, 1) = 1 Then
Caption = MenuSheet.Cells(Row, 2)
Application.CommandBars(1).Controls(Caption).Delete
End If
Row = Row + 1
Loop
On Error GoTo 0
End Sub

Sub DummyMacro()
MsgBox "This is a do nothing Macro."
End Sub

Sub About()
frmDetails.Show
End Sub

[Aussiebear]

I ain't the ghost, that be firefytr.

I'm operating in the dark here...... you all look alike to me.

[Bob Phillips]

Well, if you would stand on your feet instead of on your head ...

[Aussiebear]

I've just shot the typist..... and since I'm leaking red fluid everywhere, I'll be off.


Thanks Bob

[Bob Phillips]

Do you have a MakeSD procedure yet? It is on your macro list, but if the macro doesn't exist..it will error on trying to build the menu.

Not correct. It will error when you click the button, the menu will build quite happily (assuming that code is right).

[Aussiebear]

Hmmm.... swapped error message for Run time Error 5 Invalid proceedure call or argument.

:wot

Will get back after some soul searching.

[Bob Phillips]

I woukd guess that it is in this line in MakeSD

Call SortExtractedData(wsSD)


Can't see where wsSD is setup or defined.

[Aussiebear]

Tracked error to the following withi the DeleteMenu Sub

Error line: Application.Commandbars(1).Controls(Caption).Delete

Full Sub code

Sub DeleteMenu()

Dim MenuSheet As Worksheet
Dim Row As Integer
Dim Caption As String

'On Error Resume Next
Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")
Row = 2
Do Until IsEmpty(MenuSheet.Cells(Row, 1))
If MenuSheet.Cells(Row, 1) = 1 Then
Caption = MenuSheet.Cells(Row, 2)
Application.CommandBars(1).Controls(Caption).Delete
End If
Row = Row + 1
Loop
On Error GoTo 0
End Sub


What is this meant to be?

[Bob Phillips]

It is simply reading the data frokm your table and deleting all of level 1 of those items.