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

时间:2013-11-26 21:28:37

标签: excel excel-vba hyperlink vba

修改 经过一番研究后,我偶然发现了handy little shortcut: 只需右键单击左下角的小箭头即可显示所有工作表 - 无需代码!


我有一个包含100个标签的excel工作簿。幸运的是,标签全部编号为1-100。我有一个索引页面,其中包含连续的所有数字,我想在该行旁边添加一行,并带有指向编号选项卡的超链接。

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

等...

到目前为止,我发现最有希望的是:

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

我知道超链接功能需要:

=HYPERLINK(link_location,friendly_name)

当我手动完成时,我明白了:

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

所以我想做这样的事情:

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

但它不起作用。任何帮助深表感谢。此外,如果有一个更简单的方法来解决这个问题 - 我很满意。

4 个答案:

答案 0 :(得分:6)

使用类似的代码

  1. 按Alt + F11以打开Visual Basic编辑器(VBE)。
  2. 从“菜单”中,选择“插入模块”。
  3. 将代码粘贴到右侧代码窗口中。
  4. 关闭VBE,根据需要保存文件。
  5. 转到Tools-Macro-Macros并双击CreateTOC
    中点击“开发者”标签的“代码”组中的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
    

答案 1 :(得分:2)

我的片段:

        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

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

答案 2 :(得分:0)

可能不是你的方法的直接答案,但我会创造一些更令人愉悦的东西,比如......某些形状格式化很好,然后将一些基本宏设置为它们,以便选择床单。 这可以很容易地修改为转到特定地址(例如Go to Ctrl+G内置的Excel功能)。希望这有助于文件的时尚风格:)

修改<!/强>

不知道为什么我的答案获得-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

“basic Select Macros”应该是:

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

同样,这是一种替代方案,不会添加超链接(如询问的那样),但可以从同一位置选择工作表。

要解决外部文件链接的按钮,只需定义address&gt; filename/workbook Sheets()Open;)

答案 3 :(得分:0)

以下是我使用的代码:

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