VBA - 工作表列表（超链接）

VBA - List of sheets (hyperlinked)

提问by m-arv

I have an Excel-Workbook. In this workbook a new sheet is created via VBA.

我有一个 Excel 工作簿。在此工作簿中，通过 VBA 创建了一个新工作表。

The more sheets this workbook has the more confusing is it, because I have to scroll a long time to reach any sheet in the middle.

该工作簿的工作表越多，就越令人困惑，因为我必须滚动很长时间才能到达中间的任何工作表。

I want to create an overview-sheet

我想创建一个概览表

• in which the names of the sheets are listed AND
• the name of the sheets have to be hyperlinks.

• 其中列出了工作表的名称和
• 工作表的名称必须是超链接。

My code doesn't work at all - BTW, I have to work with Excel 2003

我的代码根本不起作用 - 顺便说一句，我必须使用 Excel 2003

Here's what I have:

这是我所拥有的：

Sub GetHyperlinks()
    Dim ws As Worksheet
    Dim i As Integer

    i = 4

    ActiveWorkbook.Sheets("overview").Cells(i, 1).Select

    For Each ws In Worksheets
        ActiveWorkbook.Sheets("overwies").Hyperlinks.Add _
        Ancor:=Selection, _
        Address:="", _
        SubAddress:="'ws.name'", _
        TextToDisplay:="'ws.name'"

        i = i + 1
    Next ws
End Sub

回答by MattCrum

Altered your code a bit - this now works:

稍微改变了你的代码 - 现在可以工作了：

Sub GetHyperlinks()
    Dim ws As Worksheet
    Dim i As Integer

    i = 4

    For Each ws In ThisWorkbook.Worksheets
        ActiveWorkbook.Sheets("overview").Hyperlinks.Add _
        Anchor:=ActiveWorkbook.Sheets("overview").Cells(i, 1), _
        Address:="", _
        SubAddress:="'" & ws.Name & "'!A1", _
        TextToDisplay:=ws.Name

        i = i + 1
    Next ws
End Sub

回答by brettdj

Two methods are used to create the links to the Active Workbook Sheets:

使用两种方法创建到活动工作簿表的链接：

1. Simple hyperlinks are created for standard Worksheets.
2. Less commonly used Chart Sheets — and even rarer Dialog Sheets — cannot be hyperlinked. If this code detects a non-Worksheet type, a Sheet BeforeDoubleClick event is programmatically added to the TOC sheet so that these Sheets can still be referenced via a short cut.

1. 为标准工作表创建了简单的超链接。
2. 不太常用的图表表——甚至更罕见的对话框表——不能被超链接。如果此代码检测到非工作表类型，则会以编程方式将 Sheet BeforeDoubleClick 事件添加到 TOC 工作表中，以便仍可通过快捷方式引用这些工作表。

Note that (2) requires that macros are enabled for this approach to work.

请注意，(2) 要求启用宏才能使这种方法工作。

Option Explicit

Sub CreateTOC()
    Dim ws As Worksheet
    Dim nmToc As Name
    Dim rng1 As Range
    Dim lngProceed As Boolean
    Dim bNonWkSht As Boolean
    Dim lngSht As Long
    Dim lngShtNum As Long
    Dim strWScode As String
    Dim vbCodeMod

    'Test for an ActiveWorkbook to summarise
    If ActiveWorkbook Is Nothing Then
        MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
        Exit Sub
    End If

    'Turn off updates, alerts and events
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

    'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
    On Error Resume Next
    Set nmToc = ActiveWorkbook.Names("TOC_Index")
    If Not nmToc Is Nothing Then
        lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
        If lngProceed = vbYes Then
            Exit Sub
        Else
            ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
        End If
    End If
    Set ws = ActiveWorkbook.Sheets.Add
    ws.Move before:=Sheets(1)
    'Add the marker range name
    ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
    ws.Name = "TOC_Index"
    On Error GoTo 0

    On Error GoTo ErrHandler

    For lngSht = 2 To ActiveWorkbook.Sheets.Count
        'set to start at A6 of TOC sheet
        'Test sheets to determine whether they are normal worksheets
        ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
        If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
            'Add hyperlinks to normal worksheets
            ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
        Else
            'Add name of any non-worksheets
            ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
            'Colour these sheets yellow
            ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
            ws.Cells(lngSht + 4, 2).Font.Italic = True
            bNonWkSht = True
        End If
    Next lngSht

    'Add headers and formatting
    With ws
        With .[a1:a4]
            .Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
            .Font.Size = 14
            .Cells(1).Font.Bold = True
        End With
        With .[a6].Resize(lngSht - 1, 1)
            .Font.Bold = True
            .Font.ColorIndex = 41
            .Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
            .Columns("A:B").EntireColumn.AutoFit
        End With
    End With

    'Add warnings and macro code if there are non WorkSheet types present
    If bNonWkSht Then
        With ws.[A5]
            .Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
            .Font.ColorIndex = 3
            .Font.Italic = True
        End With
        strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
                    & "     Dim rng1 As Range" & vbCrLf _
                    & "     Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
                    & "     If rng1 Is Nothing Then Exit Sub" & vbCrLf _
                    & "     On Error Resume Next" & vbCrLf _
                    & "     If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
                    & "     If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
                    & "End Sub" & vbCrLf

        Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
        vbCodeMod.CodeModule.AddFromString strWScode
    End If

    'tidy up Application settins
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

ErrHandler:
    If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
End Sub