用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

以下为提取目录后的效果图：