We use an overly complicated workbook for creating production schedules. A
user grabs a blank version from our network and then uses it to build
whatever schedule he or she needs. They might do this dozens of times to
build schedules for different projects. Furthermore, users might have
multiple schedule workbooks open at the same time, all of them identical
except for the data they contain.

The workbook uses a Workbook_Open event to create some custom menus and a
BeforeClose event to kill the menu. Unfortunately, it seems somewhat volatile
if you have more than one of the workbooks open at the same time, causing
random crashes. Further, since the BeforeClose event kills the custom menu,
you lose it even if you still have other copies of the workbook open, forcing
a user to close and reopen a workbook to get it back.

I guess my question is this: How can I keep the custom menu available until
the last open copy of the workbook is closed? And since the workbooks are all
identical (identical named ranges, code, etc.), is there a way to minimize
the volaltility I've described? I kind of wonder if, when a user clicks from
one workbook window to another, that somehow the identical code, named
ranges, etc. are getting tangled up somehow. Frankly, much of this code has
been cobbled together from different sources over a long period of
time--which is kind of different from actually knowing what I'm doing. Any
help would be much appreciated!

Here's the event code in This Workbook:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
If Not Me.Saved Then
Msg = "Do you want to save the changes you made to "
Msg = Msg & Me.Name & "?"
Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case Ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu
Call Delete_Controls
End Sub

Private Sub Workbook_Open()
On Error Resume Next
Call CreateMenus
Call Add_Controls
End Sub

And if it's useful, here are the procedures the events are calling:

Sub CreateMenus()
On Error Resume Next
Dim HelpMenu As CommandBarControl
Dim NewMenu As CommandBarPopup
Dim MenuItem As CommandBarControl
Dim Submenuitem As CommandBarButton

Call DeleteMenu

Set HelpMenu = CommandBars(1).FindControl(Id:=30010)

If HelpMenu Is Nothing Then
Set NewMenu = CommandBars(1).Controls _
..Add(Type:=msoControlPopup, temporary:=True)
Else
Set NewMenu = CommandBars(1).Controls _
..Add(Type:=msoControlPopup, Befo=HelpMenu.Index, _
temporary:=True)
End If

NewMenu.Caption = "Schedule Options"

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
..Caption = "WORKDAY Edit"
..OnAction = "InputMacro"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
..Caption = "Place Screen Over Selected Area"
..OnAction = "SetRectangle"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..BeginGroup = True
..Caption = "Priority for Goal and Actual Dates"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Use Actuals Only If Later Than Goals (ADP Standard)"
..OnAction = "ActDatePriorityGoal"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Always Use Actuals If Available"
..OnAction = "ActDatePriorityAct"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "Number of Proofs"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "1 Proof + 2 PDFs"
..OnAction = "One_Proof"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "2 Proofs + 2 PDFs"
..OnAction = "Two_Proofs"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "3 Proofs + 2 PDFs"
..OnAction = "Three_Proofs"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "4 Proofs + 2 PDFs"
..OnAction = "Four_Proofs"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "5 Proofs + 2 PDFs"
..OnAction = "Five_Proofs"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "More Than One ISBN?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "MultiISBNYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "MultiISBNNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "More Than One Vendor?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "MultiVendorYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "MultiVendorNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "Need Legacy Files?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "LegacyYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "LegacyNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "Ordering Go-Bys/Templates?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "GoByYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "GoByNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "Require Specs for AP?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "AP_SpecsYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "AP_SpecsNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..BeginGroup = True
..Caption = "See Editorial View?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "Editorial_ViewYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "Editorial_ViewNo"
End With

End Sub

Sub DeleteMenu()

On Error Resume Next
Application.CommandBars(1).Controls("Schedule Options").Delete

End Sub

Sub Add_Controls()
On Error Resume Next
Dim i As Long
Dim onaction_names As Variant
Dim caption_names As Variant
onaction_names = Array("InputMacro", "SetRectangle")
caption_names = Array("WORKDAY Edit", "Place Screen Over Selected Area")
With Application.CommandBars("Cell")
For i = LBound(onaction_names) To UBound(onaction_names)
With .Controls.Add(Type:=msoControlButton)
.OnAction = ThisWorkbook.Name & "!" & onaction_names(i)
.Caption = caption_names(i)
End With
Next i
End With
End Sub
Sub Delete_Controls()
On Error Resume Next
Dim i As Long
Dim caption_names As Variant
caption_names = Array("WORKDAY Edit", "Place Screen Over Selected Area")
With Application.CommandBars("Cell")
For i = LBound(caption_names) To UBound(caption_names)
On Error Resume Next
.Controls(caption_names(i)).Delete
On Error GoTo 0
Next i
End With
End Sub

Sub SetRectangle()
On Error Resume Next
Set r = Selection
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 46.5, 12#, 193.5, 53.25).Select
Selection.Top = r.Top
Selection.Left = r.Left
Selection.Height = r.Height
Selection.Width = r.Width
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
Selection.ShapeRange.Fill.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Fill.Patterned msoPattern25Percent
End Sub
Sub Deleteme()
ActiveSheet.Rectangles(Application.Caller).Delete
End Sub