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