VBA – 表单（超链接）

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

这个工作簿越多，这个工作簿就越容易混淆，因为我必须滚动很长时间才能到达中间的任何表单。

我想创build一个概览表

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

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

这是我有：

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 

Answer 1

改变了你的代码 – 现在这个工作：

 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 

Answer 2

有两种方法用于创build到活动工作簿表的链接：

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

请注意，（2）要求使用此方法来启用macros。

 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