https://www.limecode.jp/entry/fungo/051-worksheet-toc-with-links-and-pages

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：シート一覧と印刷ページ数

#VBA100本ノック 51本目
シートの一覧を作成します。
先頭に「目次」シートを追加し、
・A列にシート名を出力
・表示シートのみシート名にA1へのハイパーリンクを作成（非表示シートはリンクしない）
・B列にそのシートを印刷した時の総ページ数を出力
※シート名に注意（記号等）

シート目次

◇ 出題ページはこちら

ソースコード

メインモジュール

Option Explicit

' 100本ノック051：シート一覧と印刷ページ数
Sub アクティブブックに目次シートを挿入する()
    
    Dim wb対象ブック As Workbook
    Set wb対象ブック = ActiveWorkbook
    
    ' 既に目次シートがあれば削除
    If Isシートが存在する("目次", wb対象ブック) Then
        Call シートを削除する(wb対象ブック.Worksheets("目次"))
    End If
    
    ' 目次シートを挿入してレイアウト設定
    Dim ws目次 As Worksheet
    Set ws目次 = wb対象ブック.Worksheets.Add(wb対象ブック.Worksheets(1))
    ws目次.Name = "目次"
    ws目次.Range("A1:B1").Value = Split("シート名,印刷ページ数", ",")
    ws目次.Columns("A:B").HorizontalAlignment = xlCenter
    
    ' 対象ブックの目次以外の全シートをループ
    Dim シートNo As Long
    For シートNo = 2 To wb対象ブック.Worksheets.Count
        Dim シート As Worksheet: Set シート = wb対象ブック.Worksheets(シートNo)
        
        ' シート名
        ws目次.Cells(シートNo, 1) = シート.Name
        
        ' 表示シート時
        If シート.Visible = True Then
            
            ' ハイパーリンク
            ws目次.Cells(シートNo, 1).Hyperlinks.Add _
                Anchor:=ws目次.Cells(シートNo, 1), _
                Address:="", _
                SubAddress:=シート.Range("A1").Address(External:=True)
                
            ' 印刷ページ数
            ws目次.Cells(シートNo, 2) = シート.PageSetup.Pages.Count
            
        End If
        
    Next
    
    ' 列幅自動調整
    ws目次.Columns("A:B").AutoFit
    
End Sub

汎用関数モジュール

Option Explicit

' シートの削除
' 参考：https://www.limecode.jp/entry/procedure/displayalerts-true-false
Sub シートを削除する(削除シート As Worksheet)
    Application.DisplayAlerts = False
    削除シート.Delete
    Application.DisplayAlerts = True
End Sub

' シートの存在判定
' 参考：https://www.limecode.jp/entry/utility/existsworksheet
Function Isシートが存在する(判定シート名 As String, 指定ブック As Workbook) As Boolean

    ' ブック内の全シートを走査
    Dim ws As Worksheet
    For Each ws In 指定ブック.Worksheets

        ' シート名が一致したらTrueを返してExit
        If ws.Name = 判定シート名 Then
            Isシートが存在する = True
            Exit Function
        End If

    Next

End Function