vba 如何在一张索引表中为每个工作表创建一个超链接？

How can I create one hyperlink to each worksheet in one index sheet?

提问by Eitan

Edit:After doing a bit more research I stumbled on this handy little shortcut: Just right click on the little arrows on the bottom left corner to show all sheets - no code required!

编辑：在做了更多研究之后，我偶然发现了这个方便的小快捷方式：只需右键单击左下角的小箭头即可显示所有工作表 - 无需代码！

---

---

I have an excel workbook with 100 tabs. Luckily for me the tabs are all numbered 1-100. I Have an index page with all the numbers in a row and I would like to make a row next to that row with a hyperlink to the numbered tab.

我有一个包含 100 个选项卡的 Excel 工作簿。幸运的是，标签都编号为 1-100。我有一个索引页面，其中包含一行中的所有数字，我想在该行旁边创建一行，并带有指向编号选项卡的超链接。

   A        B
---------------------------
|  1   | link to tab 1    |
---------------------------
|  2   | link to tab 2    |
---------------------------

etc...

等等...

So far the most promising thing I've found is:

到目前为止，我发现的最有希望的事情是：

=Hyperlink(“C:\Documents and Settings\Admin1\Desktop\” & A1 & “.xls”,A1)

I know that the hyperlink function expects:

我知道超链接功能需要：

=HYPERLINK(link_location,friendly_name)

And when I do it manually, I get this:

当我手动执行时，我得到了这个：

=HYPERLINK('1'!$A,A1)

So I want to do something like this:

所以我想做这样的事情：

=HYPERLINK('& A1 &'!$A,A1)   

But it's not working. Any help is much appreciated. Also, if there is an easier way to approach this - I am all ears.

但它不起作用。任何帮助深表感谢。另外，如果有更简单的方法来解决这个问题 - 我全神贯注。

采纳答案by brettdj

With code something like this

用这样的代码

1. Press Alt + F11 to open the Visual Basic Editor (VBE).
2. From the Menu, choose Insert-Module.
3. Paste the code into the right-hand code window.
4. Close the VBE, save the file if desired.

1. 按 Alt + F11 打开 Visual Basic 编辑器 (VBE)。
2. 从菜单中，选择插入模块。
3. 将代码粘贴到右侧的代码窗口中。
4. 关闭 VBE，根据需要保存文件。

In excel-2003go to Tools-Macro-Macrosand double-click CreateTOC
In excel-2007click the Macros buttonin the Code group of the Developer tab, then click CreateTOCin the list box.

在excel-2003 中，转到Tools-Macro-Macros并双击CreateTOC
在excel-2007 中，单击Macros button“开发人员”选项卡的“代码”组中的 ，然后单击CreateTOC列表框中的 。

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

回答by rheitzman

My snippet:

我的片段：

        Sub AddLinks()
            Dim wksLinks As Worksheet
            Dim wks As Worksheet
            Dim row As Integer
            Set wksLinks = Worksheets("Links")
            wksLinks.UsedRange.Delete
            row = 1
            For Each wks In Worksheets
               ' Debug.Print wks.Name
                wks.Hyperlinks.Add wksLinks.Cells(row, 1), "", wks.Name & "!A1", , wks.Name
                row = row + 1
            Next wks
        End Sub

Assumes a worksheet named 'Links"

假设一个名为“链接”的工作表

回答by Mike Z

Here is the code I use:

这是我使用的代码：

Sub CreateIndex()

    'This macro checks for an Index tab in the active worksheet and creates one if one does not already exist.
    'If an Index tab already exists, the user is asked to continue.  If they continue, the original Index tab is replaced by a new Index tab.  If they do not continue, the macro stops.
    'The user is then asked if they want to create a link back to the Index tab on all other worksheets (yes or no) and the macro acts accordingly.

    Dim wsIndex As Worksheet
    Dim wSheet  As Worksheet
    Dim retV    As Integer
    Dim i       As Integer

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set wsIndex = Worksheets.Add(Before:=Sheets(1))

    With wsIndex

        On Error Resume Next
            .Name = "Index"
            If Err.Number = 1004 Then
                If MsgBox(Prompt:="A sheet named ""Index"" already exists. Do you wish to continue by replacing it with a new Index?", _
                Buttons:=vbInformation + vbYesNo) = vbNo Then
                    .Delete
                    MsgBox "No changes were made."
                    GoTo EarlyExit:
            End If
                Sheets("Index").Delete
                .Name = "Index"
            End If

        On Error GoTo 0

    retV = MsgBox("Create links back to ""Index"" sheet on other sheets?", vbYesNo, "Linking Options")

            For Each wSheet In ActiveWorkbook.Worksheets
            If wSheet.Name <> "Index" Then
                i = i + 1
                If wSheet.Visible = xlSheetVisible Then
                    .Range("B" & i).Value = "Visible"
                ElseIf wSheet.Visible = xlSheetHidden Then
                    .Range("B" & i).Value = "Hidden"
                Else
                    .Range("B" & i).Value = "Very Hidden"
                End If

            .Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", SubAddress:="'" & wSheet.Name & "'!A1", TextToDisplay:=wSheet.Name
            If retV = 6 And wSheet.Range("A1").Value <> "Index" Then
                wSheet.Rows(1).Insert
                wSheet.Range("A1").Hyperlinks.Add Anchor:=wSheet.Range("A1"), Address:="", SubAddress:="'" & .Name & "'!A1", TextToDisplay:=.Name
            End If

            End If
        Next wSheet

        .Rows(1).Insert
        With .Rows(1).Font
            .Bold = True
            .Underline = xlUnderlineStyleSingle
        End With

        .Range("A1") = "Sheet Name"
        .Range("B1") = "Status"
        .UsedRange.AutoFilter
        Rows("2:2").Select
        ActiveWindow.FreezePanes = True
        Application.Goto Reference:="R1C1"

        .Columns("A:B").AutoFit
    End With

    With ActiveWorkbook.Sheets("Index").Tab
        .Color = 255
        .TintAndShade = 0
    End With

    EarlyExit:
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

-Mike

-麦克风

回答by Takedasama

Might not be a direct answer to your method, but I would create something more pleasing to the eye, like ... some shapes formatted nicelyand then asign some basic macros to them, for selecting the sheets. This can be easely modified to go to a specific address (like the Go TO Ctrl+Gbuilt in Excel feature).Hope this helps on the fashion styleof your file :)

可能不是你的方法的直接答案，但我会创造一些更令人赏心悦目的东西，比如......一些格式很好的形状，然后为它们分配一些基本的宏，用于选择工作表。这可以轻松修改以转到特定地址（如Ctrl+GExcel 中内置的 Go TO 功能）。希望这有助于您的文件的时尚风格:)

EDIT!

编辑！

Don't know why my answer received a -1 rating. As I've said it's an alternative and not a direct solution to the given question. Still, I do believe my initial answer was superficial without a proven/working VBA code, thus I've developed a little practical example below:

不知道为什么我的回答得到了 -1 的评分。正如我所说，这是给定问题的替代方案，而不是直接解决方案。尽管如此，我仍然相信我最初的答案是肤浅的，没有经过验证/有效的 VBA 代码，因此我在下面开发了一个小实际示例：

Sub Add_Link_Buttons()
        'Clear any Shapes present in the "Links" sheet
    For j = ActiveSheet.Shapes().Count To 1 Step -1
    ActiveSheet.Shapes(j).Delete
    Next j
        'Add the shapes and then asign the "Link" Macros
    For i = 1 To ActiveWorkbook.Sheets.Count
    ActiveSheet.Shapes.AddShape Type:=msoShapeRoundedRectangle, Left:=50, Top:=i * 25, Width:=100, Height:=25
    ActiveSheet.Shapes(i).OnAction = "Select_Sheet" & i
    'even add the the sheet Name as Test:
    ActiveSheet.Shapes(i).TextFrame2.TextRange.Characters.Text = Sheets(i).Name
    Next i
End Sub

where the "basic Select Macros"whould be:

其中“基本选择宏”应该是：

Sub Select_Sheet1()
    ActiveWorkbook.Sheets(1).Select
End Sub
Sub Select_Sheet2()
    ActiveWorkbook.Sheets(2).Select
End Sub
Sub Select_Sheet3()
    ActiveWorkbook.Sheets(3).Select
End Sub
' and so on!
' Note! to link a specific address within the sheets use the range like in 'Sheets(1).Range("A1").Select

Again, This is an alternative and doesn't add hyperlinks (as asked), but enables the sheet select from the same location.

同样，这是一种替代方法，不会添加超链接（按要求），但可以从同一位置选择工作表。

TO address the buttons to links for outside files, simply define the address> filename/workbookSheets()and Open;)

要处理指向外部文件链接的按钮，只需定义address>filename/workbookSheets()和Open;)