我怎样才能创build一个超链接到一个索引表中的每个工作表？

编辑：在做了一些更多的研究后，我偶然发现了这个方便的小捷径 ：只需右键点击左下angular的小箭头即可显示所有表格 – 无需代码！

---

我有一个有100个选项卡的Excel工作簿。 幸运的是，这些标签都是1-100。 我有一个索引页，连同所有的数字，我想在该行旁边制作一个超链接到编号标签。

AB --------------------------- | 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) 

但它不工作。 任何帮助深表感谢。 另外，如果有更简单的方法来解决这个问题 – 我全部都是耳朵。

Answer 1

有了这样的代码

1. 按Alt + F 11打开Visual Basic编辑器（VBE）。
2. 从菜单中select插入模块。
3. 将代码粘贴到右侧的代码窗口中。
4. closuresVBE，如果需要保存文件。

在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 

Answer 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 

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

Answer 3

可能不是你的方法的直接答案，但我会创造一些更令人愉快的眼睛，比如…一些形状很好的格式 ，然后为他们select一些基本的macros，select表。 这可以轻松地修改到一个特定的地址（如在Excelfunction中build立的转到Ctrl+G ）。希望这有助于您的文件的时尚风格 🙂

编辑！

不知道为什么我的答案收到-1评级。 正如我所说，这是一个替代scheme，而不是一个直接的解决scheme。 不过，我相信我的初步答案是没有经过validation的工作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 

“基本selectmacros”应该是：

 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 

再次，这是一个替代scheme，不会添加超链接（如问），但可以从同一位置select表格。

要寻址外部文件链接的button，只需定义address > filename/workbook Sheets()和Open ;）

Answer 4

这是我使用的代码：

 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 

-麦克风