Excel-用VBA为你的工作表制作一个目录

我们在工作中常用到一系列报告。它们有一个特点，这个特点就是报告里用到很多数据。这时候我们就遇见一种苦恼。如果用PPT呢，又是纯展示的工具，如果用word，它又是纯文字处理的工具。

而我想要得到一定的文本和数字混合呈现技术。那么Excel不失成为你的一种选择。

需求

我在每个Sheet里面有各自的主题。例如您在做IATF内审时候需要统计各自区域的得分。

我想要知道总体目录是什么样，每个部分的篇幅是多少。

能否赋予一个超链接快速访问的实现，这些都是现实需求。

更新的内容，能否在目录里面相应的更新。

实现

在视图模式里是有分页预览按钮的，它可以快速区分整个Sheet用了多少页。这也是我们目录的制作要素之一。

以2/10我的文章素材作为案例。我共有五个页面。我需要新建一个Sheet，并统计他们各自用了多少页。然后再建立超链接。

实现代码

Option ExplicitSub Create_TOC()Dim wbBook As WorkbookDim wsActive As WorksheetDim wsSheet As WorksheetDim lnRow As LongDim lnPages As LongDim lnCount As LongSet wbBook = ActiveWorkbookWith Application .DisplayAlerts = False .ScreenUpdating = FalseEnd With
On Error Resume NextWith wbBook .Worksheets('TOC').Delete .Worksheets.Add Before:=.Worksheets(1)End WithOn Error GoTo 0Set wsActive = wbBook.ActiveSheetWith wsActive .Name = 'TOC' With .Range('A1:B1') .Value = VBA.Array('Table of Contents', 'Sheet # - # of Pages') .Font.Bold = True End WithEnd WithlnRow = 2lnCount = 1
For Each wsSheet In wbBook.Worksheets If wsSheet.Name <> wsActive.Name Then wsSheet.Activate With wsActive .Hyperlinks.Add .Cells(lnRow, 1), '', _ SubAddress:=''' & wsSheet.Name & ''!A1', _ TextToDisplay:=wsSheet.Name lnPages = wsSheet.PageSetup.Pages().Count .Cells(lnRow, 2).Value = ''' & lnCount & '-' & lnPages End With lnRow = lnRow 1 lnCount = lnCount 1 End IfNext wsSheetwsActive.ActivatewsActive.Columns('A:B').EntireColumn.AutoFitWith Application .DisplayAlerts = True .ScreenUpdating = TrueEnd WithEnd Sub


运行视频：