Excel 自动目录，真好用!我们不一样!上源码和详细注释

yumo6661个月前 (03-24)技术文章18

非同一般的"Excel 自动目录"：

我这个不同于网上其它那些不够自动化的、不够标准化的"Excel 自动目录"。

Excel工作簿内有太多工作表时，Excel自带的工作表目录，一屏显示不完

本文VBA程序自动生成的目录如下图：

优点：

自动化：只要进入Index工作表，程序即可自动创建或更新工作簿索引目录。
简单化：无需任何其它设置：无需创建按钮或公式等等，统统都不需要
标准化：每次生成的目录都有统一标准格式
系统化：带超链接（蓝色下划线），点击工作表名称，就跳转到工作表
智能化：默认不显示隐藏工作表，但通过筛选显示出来；自动设置字体格式、保护目录
及时化：运行快速，瞬间完成；随时更新，自动更新

VBA源码和详细注释：

' Thisworkbook.cls
Option Explicit

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = "Index" Then
        Call updateIndex   ' Excel VBA 持续超越  by Jeffrey JC Li
    End If
End Sub

Private Sub updateIndex _
                                        (Optional wbk As Workbook)  ' Excel VBA 持续超越  by Jeffrey JC Li
    Application.ScreenUpdating = False
    Debug.Print Now, "Start:  updateIndex()."
    Dim rtv
    Dim wst As Worksheet
    Dim lRow1 As Long
    Dim lCol1 As Long
    Dim lRowMax As Long
    Dim lColMax   As Long
    Dim lColLink As Long
    Dim ll As Long
    Dim tm0 As Date
    Dim tm1 As Date
    tm0 = Timer
    If wbk Is Nothing Then Set wbk = ActiveWorkbook
    If Not SheetExists("Index", wbk.Name) Then
        wbk.Sheets.Add.Name = "Index"
    End If
    wbk.Sheets("Index").Move Before:=Sheets(1)
    Set wst = wbk.Sheets("Index")
    lRow1 = 3      ' 目录内容第一行所在行号=3
    lCol1 = 1        ' 目录最左边列号
    lRowMax = wbk.Sheets.Count + lRow1 - 1       ' 目录最后一行的行号
    lColLink = 2   ' 目录链接所在列号
    lColMax = lColLink + 1  ' 目录最右边列号
    ' 目录共3列：编号，名称链接，和名称文本
    Call clearIndex    ' 先清除目录 '
    With wst
        ' 取消保护
        If .ProtectionMode = True Then
            Call unprotectSheet(wst)   ' 
        End If
        ' 填写表头
        .Cells(1, 1).Value = "Index"
        .Cells(1, 1).Value = wbk.Name
        .Cells(2, 1) = "No. 编号"
        .Cells(2, 2).Value = "Sheet 工作表"
        .Cells(2, 3).Value = "Visible 是否可见"
        .Cells(2, 4).Value = "Remark 备注"
        '生成目录超链接和文本
        For ll = 1 To wbk.Sheets.Count
            '填写工作表序号
            .Cells(ll + lRow1 - 1, lCol1).Value = ll
            '填写每个工作表名称，并生成超链接
            .Hyperlinks.Add _
                    Anchor:=.Cells(ll + lRow1 - 1, lCol1 + 1), _
                    Address:="", _
                    SubAddress:="'" & Sheets(ll).Name & "'!A1", _
                    TextToDisplay:="'" & Sheets(ll).Name
            '''备注每个工作表是否为可见（非隐藏.Visible = xlSheetVisible ）
                If Sheets(ll).Visible = True Then
                    .Cells(ll + lRow1 - 1, lCol1 + 2).Value = "Yes"
                Else
                    .Cells(ll + lRow1 - 1, lCol1 + 2).Value = "No"
                End If
        Next
        '设置单元格格式 区域: A1" & ":D" & lRowMax
        .Range("A1" & ":D" & lRowMax).Select
        ' 设置表格边框线格式
        Call setBorderStyleAsMyCustom   ' 
        Call setFontArialColorBlackSize10   ' 
        Call setRangeAlignmentCenter   ' 
        '修改B列 上左对齐
        .Range("B" & lRow1 & ":B" & lRowMax).Select
        Call setRangeAlignmentLeftTop   ' 
        Call setFontArialColorBlueSize10
        '设置B列 下划线
        Call setUnderline
        '删除所有条件格式
        .Cells.FormatConditions.Delete
        ' 新增条件格式（C列含有No的单元格，显示为红色）
        With .Columns("C:C")
            .FormatConditions.Add _
                Type:=xlTextString, _
                String:="No", _
                TextOperator:=xlContains
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Font
                .Color = -16776961
                .TintAndShade = 0
            End With
            .FormatConditions(1).StopIfTrue = False
        End With
        ' 增加公式型条件格式，将所有隐藏工作表行的背景色设置为灰色
        With .Range("A3:D" & lRowMax)
            .FormatConditions.Add _
                Type:=xlExpression, _
                Formula1:="=$C3=""No"""     ' 条件：如果C列任意单元格是No
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            With .FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1     ' 则设置为主题颜色灰色
                .TintAndShade = -0.05                         ' -1~1   ' -1暗 1亮
            End With
            .FormatConditions(1).StopIfTrue = False
        End With
        ' 自动筛选：仅显示C列为Yes的行（即：隐藏的工作表不显示）
        If .AutoFilterMode Or .FilterMode Then
            .Rows("2:2").AutoFilter
            .Rows("2:2").AutoFilter
        Else
            .Rows("2:2").AutoFilter
        End If
        .Rows("2:2").AutoFilter Field:=3, Criteria1:="Yes"
        ' 设置列宽： 自适应
        '.Columns("A:A").ColumnWidth = 10   ' A: 10     B: 50   C: 25   D: 30
        .Columns("A:C").EntireColumn.AutoFit
        .Columns("D:D").ColumnWidth = 30
        ' 设置行高： 自适应
        .Cells.EntireRow.AutoFit
        ' 冻结窗格
        .Range("B3").Select
        ActiveWindow.FreezePanes = True
        ' 隐藏网格线
        ActiveWindow.DisplayGridlines = False
        ' 选择单元格
        .Cells(lRow1, "E").Select
        ' 保护工作表 密码为空        'Call ProtectSheet(wst)
        .Protect
    End With
    tm1 = Timer
    Debug.Print Now, "Done updateIndex(). Time elapsed: " & Round(tm1 - tm0, 0) & " s."
    Application.ScreenUpdating = True
    MsgBox "完成：更新目录！Complete updating index of workbook. " & vbCrLf & vbCrLf & _
                "用时：Time elapsed: " & Round(tm1 - tm0, 3) & " s.", _
                vbOKOnly + vbDefaultButton1 + vbInformation + vbApplicationModal, _
                "Excel VBA 持续超越  by Jeffrey JC Li"
    Set wst = Nothing
    Set wbk = Nothing
End Sub