Excel生成目录

Sub 建立目录()
    Dim i As Byte
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim XStr, YStr, ZStr
    XStr = " -"
    ZStr = ""
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "目录" Then
            Exit For
        End If
    Next
    If i > Worksheets.Count Then Sheets.Add.Name = "目录"
    Sheets("目录").Move before:=Sheets(1)
    Sheets("目录").Select
    Range("A:B").Clear
    Range("B:B").NumberFormatLocal = "@"
    Worksheets(1).Cells(1, 1).Value = "编号"
    Worksheets(1).Cells(1, 2).Value = "目录"
    For i = 2 To Worksheets.Count
        Worksheets(1).Cells(i, 1).Value = i - 1
        Worksheets(1).Cells(i, 2).Value = Worksheets(i).Name
        For j = 1 To Len(Worksheets(i).Name)
            YStr = Mid(Worksheets(i).Name, j, 1)
            If InStr(XStr, YStr) <> 0 Then
                ZStr = "'"
                Exit For
            End If
        Next
        ActiveSheet.Hyperlinks.Add Anchor:=Worksheets(1).Cells(i, 2), Address:="", SubAddress:=ZStr & Worksheets(i).Name & ZStr & "!A1", TextToDisplay:=Worksheets(i).Name
    Next
    Columns("A:A").HorizontalAlignment = xlCenter
    Columns("A:A").VerticalAlignment = xlCenter
    Columns("B:B").HorizontalAlignment = xlLeft
    Columns("B:").VerticalAlignment = xlLeft
    Range("d2").Select
    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True

End Sub

原始地址 http://club.excelhome.net/thread-1243181-1-1.html