用Excel VBA制作表格目录
说明：当Excel工作簿有很多表格时，或者为了操作管理的便捷，我们需要提取表格的目录来使表格更方便的使用。以下是个人写的VBA代码，其实已经有很多Excel工具箱有提取目录的功能，我自己写代码一是个人的兴趣爱好，二是我需要增强自己的编程能力，这些代码可分享供大家使用，但最主要的是写给真正懂的人看，写给想学VBA的童鞋看，也希望高手们能指出不足之处，能改进之处。
'---------------------------------------------------------
' Procedure : 提取目录
' Author : 俊学之道
' Purpose : 创建目录并增加超链接
' Date : 2015-7-16
' Place : 厦门
'---------------------------------------------------------
Sub 提取目录()
On Error Resume Next '忽略错误
Application.DisplayAlerts = False '取消提示警告
Application.ScreenUpdating = False '取消屏幕更新
Sheets("目录").Delete '如果有目录表格便先删除
'调用过程(注意：如果表格有图片，插入的形状，艺术字，剪贴画，OLE对象都将被删除，请谨慎使用)
Call 删除工作簿的所有shape对象 '调用过程
'增加一个表格并重命名为目录，目录表格的代码名称序号是最大的
Worksheets.Add before:=Worksheets(1) '第一个标签名前增加新表格
ActiveSheet.Name = "目录" '增加的新表格重命名为目录
Dim i As Integer
For i = 1 To Sheets.Count - 1 '由于增加了目录表格使工作表数目多了一个，需要减去一个
'A列编号
Cells(1, 1) = "编号"
Cells(i + 1, 1) = i
'B列目录
Cells(1, "B") = "目录"
Cells(i + 1, "B") = Worksheets(i + 1).Name '每个工作表的名称赋值到目录页的B列
Next
'冻结窗格
With ActiveWindow
.SplitColumn = 4
.SplitRow = 1
End With
ActiveWindow.FreezePanes = 1 '1或true冻结，0取消冻结
Call 增加超链接 '调用过程
Application.ScreenUpdating = True '恢复屏幕更新
Application.DisplayAlerts = True '恢复提示警告
End Sub
'---------------------------------------------------------
'以下为将要调用的两个过程
'---------------------------------------------------------
'过程1：删除工作簿的所有shape对象
'---------------------------------------------------------
Sub 删除工作簿的所有shape对象()
For Each Sht In Worksheets
Sht.Activate
ActiveSheet.Shapes.SelectAll '选中当前工作表的所有shape对象
Selection.Delete
Next
End Sub
'---------------------------------------------------------
'过程2：增加超链接
'---------------------------------------------------------
Sub 增加超链接() '这个过程应该还有改进简化的空间，现在水平不足，将来继续改进
On Error Resume Next '忽略错误
i = 1
For Each Sht In Worksheets
'a.目录页增加超链接地址
Sheets("目录").Hyperlinks.Add Anchor:=Sheets("目录").Cells(i + 1, 2), Address:="", SubAddress:="'" & Worksheets(i + 1).Name & "'" & "!A1"
i = i + 1
Sht.Activate '遍历工作表使每个工作表成为当前窗口
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 700, 20, 100, 30).Select '在每个当前工作表增加Textbox
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "返回目录"
Selection.ShapeRange.Line.Visible = msoFalse '无形状轮廓
Selection.ShapeRange.Fill.Visible = msoFalse '无形状填充
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 4).Font.Line
.Visible = msoTrue '有文本轮廓
.ForeColor.RGB = RGB(0, 112, 192) '文本轮廓的颜色
End With
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 4).ParagraphFormat.Alignment = msoAlignCenter
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 4).Font.Size = 15
'b.Textbox增加超链接至目录页
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="", SubAddress:="'目录'!A1"
ActiveSheet.Cells(1, 1).Select '定位在A1单元格
Next Sht
Sheets("目录").Select '定位在目录页
ActiveSheet.Shapes.SelectAll '选中当前工作表的所有shape对象
Selection.Delete '删除选中的多余shape对象
End Sub
以下为提取目录后的效果图：
效果图1
表格里有返回目录的按钮：
效果图2
