vba - VBA - シートのリスト (ハイパーリンク)

Question

私はExcelワークブックを持っています。このワークブックでは、VBA を使用して新しいシートが作成されます。

このワークブックに含まれるシートが多いほど、混乱が大きくなります。途中のシートに到達するまでに長時間スクロールする必要があるからです。

概要シートを作成したい

シートの名前がリストされている AND
シートの名前はハイパーリンクでなければなりません。

コードがまったく機能しません - ところで、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

score 3 · Accepted Answer

コードを少し変更しました - これで動作します:

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

score 2 · Accepted Answer

アクティブワークブックシートへのリンクを作成するには、次の 2 つの方法が使用されます。

標準のワークシートには、単純なハイパーリンクが作成されます。
あまり使用されていないグラフシート (さらにはまれなダイアログシート) は、ハイパーリンクできません。このコードが Worksheet 以外のタイプを検出した場合、Sheet BeforeDoubleClick イベントがプログラムで TOC シートに追加され、これらの Sheet をショートカット経由で引き続き参照できるようになります。

(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

vba - VBA - シートのリスト (ハイパーリンク)

2 に答える 2

Related

Reference