用Excel VBA制作表格目錄
說(shuō)明：當(dāng)Excel工作簿有很多表格時(shí)，或者為了操作管理的便捷，我們需要提取表格的目錄來(lái)使表格更方便的使用监氢。以下是個(gè)人寫的VBA代碼，其實(shí)已經(jīng)有很多Excel工具箱有提取目錄的功能藤违，我自己寫代碼一是個(gè)人的興趣愛(ài)好浪腐，二是我需要增強(qiáng)自己的編程能力，這些代碼可分享供大家使用顿乒，但最主要的是寫給真正懂的人看议街，寫給想學(xué)VBA的童鞋看，也希望高手們能指出不足之處淆游，能改進(jìn)之處傍睹。
'---------------------------------------------------------
' Procedure : 提取目錄
' Author : 俊學(xué)之道
' Purpose : 創(chuàng)建目錄并增加超鏈接
' Date : 2015-7-16
' Place : 廈門
'---------------------------------------------------------
Sub 提取目錄()
On Error Resume Next '忽略錯(cuò)誤
Application.DisplayAlerts = False '取消提示警告
Application.ScreenUpdating = False '取消屏幕更新
Sheets("目錄").Delete '如果有目錄表格便先刪除
'調(diào)用過(guò)程(注意：如果表格有圖片，插入的形狀犹菱，藝術(shù)字，剪貼畫吮炕，OLE對(duì)象都將被刪除腊脱，請(qǐng)謹(jǐn)慎使用)
Call 刪除工作簿的所有shape對(duì)象 '調(diào)用過(guò)程
'增加一個(gè)表格并重命名為目錄，目錄表格的代碼名稱序號(hào)是最大的
Worksheets.Add before:=Worksheets(1) '第一個(gè)標(biāo)簽名前增加新表格
ActiveSheet.Name = "目錄" '增加的新表格重命名為目錄
Dim i As Integer
For i = 1 To Sheets.Count - 1 '由于增加了目錄表格使工作表數(shù)目多了一個(gè)龙亲，需要減去一個(gè)
'A列編號(hào)
Cells(1, 1) = "編號(hào)"
Cells(i + 1, 1) = i
'B列目錄
Cells(1, "B") = "目錄"
Cells(i + 1, "B") = Worksheets(i + 1).Name '每個(gè)工作表的名稱賦值到目錄頁(yè)的B列
Next
'凍結(jié)窗格
With ActiveWindow
.SplitColumn = 4
.SplitRow = 1
End With
ActiveWindow.FreezePanes = 1 '1或true凍結(jié)陕凹，0取消凍結(jié)
Call 增加超鏈接 '調(diào)用過(guò)程
Application.ScreenUpdating = True '恢復(fù)屏幕更新
Application.DisplayAlerts = True '恢復(fù)提示警告
End Sub
'---------------------------------------------------------
'以下為將要調(diào)用的兩個(gè)過(guò)程
'---------------------------------------------------------
'過(guò)程1：刪除工作簿的所有shape對(duì)象
'---------------------------------------------------------
Sub 刪除工作簿的所有shape對(duì)象()
For Each Sht In Worksheets
Sht.Activate
ActiveSheet.Shapes.SelectAll '選中當(dāng)前工作表的所有shape對(duì)象
Selection.Delete
Next
End Sub
'---------------------------------------------------------
'過(guò)程2：增加超鏈接
'---------------------------------------------------------
Sub 增加超鏈接() '這個(gè)過(guò)程應(yīng)該還有改進(jìn)簡(jiǎn)化的空間，現(xiàn)在水平不足鳄炉，將來(lái)繼續(xù)改進(jìn)
On Error Resume Next '忽略錯(cuò)誤
i = 1
For Each Sht In Worksheets
'a.目錄頁(yè)增加超鏈接地址
Sheets("目錄").Hyperlinks.Add Anchor:=Sheets("目錄").Cells(i + 1, 2), Address:="", SubAddress:="'" & Worksheets(i + 1).Name & "'" & "!A1"
i = i + 1
Sht.Activate '遍歷工作表使每個(gè)工作表成為當(dāng)前窗口
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 700, 20, 100, 30).Select '在每個(gè)當(dāng)前工作表增加Textbox
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "返回目錄"
Selection.ShapeRange.Line.Visible = msoFalse '無(wú)形狀輪廓
Selection.ShapeRange.Fill.Visible = msoFalse '無(wú)形狀填充
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增加超鏈接至目錄頁(yè)
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:="", SubAddress:="'目錄'!A1"
ActiveSheet.Cells(1, 1).Select '定位在A1單元格
Next Sht
Sheets("目錄").Select '定位在目錄頁(yè)
ActiveSheet.Shapes.SelectAll '選中當(dāng)前工作表的所有shape對(duì)象
Selection.Delete '刪除選中的多余shape對(duì)象
End Sub
以下為提取目錄后的效果圖：
效果圖1
表格里有返回目錄的按鈕：
效果圖2
