VBA - 工作表（超链接）

Question

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

这张工作手册中的页数越多，就越容易混淆，因为我必须长时间滚动才能到达中间的任何页面。

我想创建一个概述表

• 沿片的名称列出，并
• 纸张的名称必须是超链接。

我的代码不会在所有的工作 - BTW，我用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

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

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

请注意，（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