今天我們繼續(xù)分享目錄制作，前面我們分享了WPS中的實(shí)現(xiàn)和Excel中函數(shù)模版法,，今天我們分享VBA一鍵搞定,，通用,！制作目錄,，首先我們要判斷工作表中是否有【目錄導(dǎo)航】這張表，一般都沒有,，如果沒有代碼自動創(chuàng)建一個(gè)吧,，就不用大家手工去創(chuàng)建了，這樣通用性才更好,！
01 - 自動創(chuàng)建目錄導(dǎo)航表代碼首先判斷【目錄導(dǎo)航】表是否存在,，如果存在就清空內(nèi)容，方便我們下一步使用,，如果不存在就在當(dāng)前文檔中的第一個(gè)表前插入一個(gè)表,，并修改名稱為【目錄導(dǎo)航】，代碼全自動處理，無需任何人工干預(yù),！導(dǎo)航表有了之后,，我們就把全部表名稱添加到【目錄導(dǎo)航】表中，并添加超鏈接,，方便我們跳轉(zhuǎn),！
這里主要知識點(diǎn)就 For Each循環(huán)和寫入單元格，這些都是VBA基礎(chǔ)知識,！
我們自己使用,，直接按照上圖，點(diǎn)擊對應(yīng)的宏直接運(yùn)行就會自動生成,！
現(xiàn)在已經(jīng)實(shí)現(xiàn)了自動生成,，但是有的同學(xué)就反饋說，能不能在每個(gè)表中添加一個(gè)【返回目錄】的功能,，下面我們就來實(shí)現(xiàn),！返回目錄這里主要使用圖形來做，這樣可以在保證不破壞數(shù)據(jù)的情況,，在每個(gè)表中都添加一個(gè)返回目錄的圖形,，點(diǎn)擊快速返回，如果有遮擋,，還可以拖動圖形位置來處理,！現(xiàn)寫，爆肝兩小時(shí),，終于全部搞定,，下面我們整理一下代碼，把三個(gè)功能整合一下,，大家點(diǎn)擊【一鍵目錄】即可一鍵搞定,，不用做任何處理！
再添加一個(gè)過程,，依次調(diào)用上面三步,，我們只需要執(zhí)行這個(gè)過程即可一鍵搞定
▼完整源碼如下：左右滑動查看，一鍵復(fù)制使用
Option Explicit
'功能：創(chuàng)建【目錄導(dǎo)航】工作表'作者：E精精'----------------------------------------------Sub 創(chuàng)建目錄工作表() Dim ct_sht As Worksheet On Error Resume Next Set ct_sht = Worksheets('目錄導(dǎo)航') '存在就清空,，不存在創(chuàng)建一個(gè) If Err.Number = 0 Then ct_sht.Cells.Clear Else ThisWorkbook.Worksheets.Add Before:=Worksheets(1) ActiveSheet.Name = '目錄導(dǎo)航' End IfEnd Sub
'功能: 生成帶超鏈接的工作表目錄'作者：E精精'----------------------------------------------Sub 超鏈接目錄() Dim sht As Worksheet, n As Long With Sheets('目錄導(dǎo)航') '標(biāo)題 .[A1:b1] = Array('序號', '工作表名稱') .Columns(1).HorizontalAlignment = XlHAlign.xlHAlignCenter '循環(huán)添加到目錄導(dǎo)航表中 For Each sht In ThisWorkbook.Worksheets If sht.Name <> '目錄導(dǎo)航' Then n = n + 1 .Cells(n + 1, 1) = n '添加超鏈接 .Hyperlinks.Add .Cells(n + 1, 2), '', _ ''' & sht.Name & ''!A1', , sht.Name .Cells(n + 1, 2).Font.Underline = False End If Next End WithEnd Sub
'功能: 每個(gè)表中返回目錄功能
Option Explicit
'功能：創(chuàng)建【目錄導(dǎo)航】工作表'作者：E精精'----------------------------------------------Sub 創(chuàng)建目錄工作表() Dim ct_sht As Worksheet On Error Resume Next Set ct_sht = Worksheets('目錄導(dǎo)航') '存在就清空,，不存在創(chuàng)建一個(gè) If Err.Number = 0 Then ct_sht.Cells.Clear Else ThisWorkbook.Worksheets.Add Before:=Worksheets(1) ActiveSheet.Name = '目錄導(dǎo)航' End IfEnd Sub
'功能: 生成帶超鏈接的工作表目錄'作者：E精精'----------------------------------------------Sub 超鏈接目錄() Dim sht As Worksheet, n As Long With Sheets('目錄導(dǎo)航') '標(biāo)題 .[A1:b1] = Array('序號', '工作表名稱') .Columns(1).HorizontalAlignment = XlHAlign.xlHAlignCenter '循環(huán)添加到目錄導(dǎo)航表中 For Each sht In ThisWorkbook.Worksheets If sht.Name <> '目錄導(dǎo)航' Then n = n + 1 .Cells(n + 1, 1) = n '添加超鏈接 .Hyperlinks.Add .Cells(n + 1, 2), '', _ ''' & sht.Name & ''!A1', , sht.Name .Cells(n + 1, 2).Font.Underline = False End If Next End WithEnd Sub
'功能: 每個(gè)表中返回目錄功能'作者：E精精'----------------------------------------------Sub 返回目錄() Dim shp As Shape, sht As Worksheet For Each sht In Sheets If sht.Name <> '目錄導(dǎo)航' Then '刪除原有的 For Each shp In sht.Shapes If shp.Name = sht.Name Then shp.Delete End If Next '重新添加 Set shp = sht.Shapes.AddShape(msoShapeRectangle, 15, 15, 80, 20) sht.Activate With shp .Name = sht.Name .Select .TextFrame2.TextRange.Text = '返回目錄' End With sht.Hyperlinks.Add Selection.ShapeRange.Item(1), '', '目錄導(dǎo)航!A1' End If Next Sheets('目錄導(dǎo)航').ActivateEnd Sub
Sub 一鍵目錄() '調(diào)用生成 目錄導(dǎo)航工作表功能 Call 創(chuàng)建目錄工作表 '調(diào)用生成目錄超鏈接 Call 超鏈接目錄 '添加返回目錄功能 Call 返回目錄 End Sub
|
