怎样使用VBA建立菜单式工作表目录？

1、首先在开发工具中打开VBA编辑器

2、在单元格区域当中输入一些内容作为例子

3、在VBA编辑器中插入模块

4、在模块当中输入如下代码，然后运行

Sub Auto_Open()

 

Dim BarCtlBtn As CommandBarButton

 

  '*********建立菜单按钮***************

 

    With Application.CommandBars("Worksheet Menu Bar").Controls

 

          .Add(Type:=msoControlButton)

 

          .Style=msoButtonIconAndCaption '有图标和文字

 

          .Caption="建立目录"

 

          .FaceId=481

 

          .OnAction="Create_contents"

 

      End With

 

End Sub

 

Sub Create_contents() '建立目录

 

On Error Resume Next

 

Application.CommandBars("Worksheet Menu Bar").Controls("工作表目录").Delete

 

Dim Sh As Worksheet

 

'添加新菜单

 

With Application.MenuBars(xlWorksheet).Menus.Add("工作表目录") '建立新菜单

 

'新菜单开始新组并添加文字提示

 

Set myMenuBar=CommandBars.ActiveMenuBar

 

Set lastctrl=myMenuBar.Controls(myMenuBar.Controls.Count)

 

  lastctrl.BeginGroup=True                                '开始新组

 

  lastctrl.TooltipText="建立工作表目录，单击可链接至相应工作表。"  '文字提示

 

'添加子菜单

 

For Each Sh In ActiveWorkbook.Sheets

 

 .MenuItems.Add Sh.Name, "into"          '添加子菜单，与工作表数目相同

 

  Next

 

.MenuItems.Add "请选择工作表名", "", , 1          '1表示移至第1个控件之前

 

.MenuItems.Add "刷新菜单目录", "f5"

 

End With

 

Application.CommandBars("Worksheet Menu Bar").Controls("建立目录")

 

.Visible=False

 

Call group

 

End Sub

 

Sub into() '进入工作表

 

  Dim Item As MenuItem

 

  Sheets(Application.CommandBars.ActionControl.Caption).Select

 

  '加选择框

With Application.MenuBars(xlWorksheet).Menus("工作表目录")

 

    For Each Item In .MenuItems

 

      Item.Checked=False

 

Next Item

 

.MenuItems(Application.CommandBars.ActionControl.Caption).Checked=True

 

End With

 

End Sub

 

Sub f5()

 

Call Create_contents

 

End Sub

 

Sub group() '为菜单设置图标

 

Dim Y As Byte

 

Y=Application.CommandBars("Worksheet Menu Bar").Controls("工作表目录").

 

Controls.Count

 

With Application.CommandBars("Worksheet Menu Bar").Controls("工作表目录")

 

.Controls(1).FaceId=176

 

.Controls(2).BeginGroup=True

 

.Controls(Y).BeginGroup=True

 

.Controls(Y).FaceId=481

 

If .Controls(2).Caption="工作表目录" Then .Controls(2).Delete

'  End If

 

End With

 

End Sub

 

Sub auto_close() '关闭工作表时删除菜单

 

Application.CommandBars(1).Reset

 

End Sub

5