【VBA】目次の自動生成

Excel VBA マクロとハイパーリンクの組み合わせで目次生成の自動化を行います。
２つのボタン「目次作成」、「シート追加」で制御します。

このツールを作成した目的はマニュアル作成を効率的に進めたい！という思いが原動力になっています。

30日間無料登録できる「Amazonプライム会員」に登録すれば、翌日に購入した商品が届くお急ぎ便・お届け日時指定便の指定ができるので、荷物をなるべく早く受け取りたい人にオススメ！

無料体験期間中もAmazonプライムビデオや1億曲以上聞き放題のAmazon Musicなど、すべてのプライム会員特典がセットになっています！

　　30日間の無料体験はこちら！　　

うめ

30日間以内に解約すれば費用は発生しません！

処理の流れ
1. 目次作成
2. シート追加
コピペで使えるコード

処理の流れ

今回はどのボタンを選択したかによって動き方が異なります。
一つのSubプロシージャでボタン判定の処理を行っています。

目次作成

目次作成の用途

手動で追加したシートを目次に表示します。(ハイパーリンク付き)

「目次作成」のボタンを選択した場合

共通ルートの処理に進み
読み込んだシート名を目次に設定
シート名に遷移するようにハイパーリンクを設定
読み込んだシートのA1セルが空の場合に目次に戻るためのハイパーリンクを設定

シート追加

シート追加の用途

シートの追加、ハイパーリンクの設定を同時に行います。

「シート追加」のボタンを選択した場合

シート追加を選択した場合、指定した名前のシートを末尾に追加
追加シートのA1セルに目次に戻るためのハイパーリンクを追加
目次作成と同様の処理

コピペで使えるコード

ソースをコピペ後に２つのボタンを設置します。
※どちらにも「目次作成」のマクロを設定

Sub 目次作成()

Dim Ws1 As Worksheet
Set Ws1 = Worksheets("目次")

'処理前に列情報をクリア
Columns(2).Clear
Ws1.Cells(2, "B") = "目次"

'選択したボタン名を取得
Dim Button_Name As String: Button_Name = ActiveSheet.Buttons(Application.Caller).Text

'シート追加を選択した場合
If Button_Name = "シート追加" Then

    Dim Sh_Add As String: Sh_Add = InputBox("シート名を指定して下さい。", "シート名確認", "")
    
    '追加シート名が未入力の場合は処理を止める
    If Sh_Add = "" Then
    
        MsgBox "シート名を設定してください。", vbYesNo + vbExclamation, "エラー"
        Exit Sub
    
    End If
    
    '右端にシートを追加
    Worksheets().Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Sh_Add
    
    '目次へ戻るを設定
    Ws1.Hyperlinks.Add Anchor:=Range("A1"), Address:="", SubAddress:="目次!A1", ScreenTip:="ヒントを表示", TextToDisplay:="目次へ戻る"
    
End If

'共通ルート
Dim Sh_Sta As Long: Sh_Sta = 2  'シート読込開始位置
Dim Sh_Name As String           '読込シート名
Dim Sh_Cnt As Long: Sh_Cnt = Worksheets.Count  'シート数取得

'全シートを読み込むまで繰り返し
Do While Sh_Sta <> Sh_Cnt + 1

    '目次シートに読み込んだシート名を設定
    Sh_Name = Worksheets(Sh_Sta).Name
    Ws1.Cells(Sh_Sta + 1, "B") = Sh_Name
    
    '読み込んだシートのA1セルに飛ぶようにハイパーリンクを設定
    Ws1.Hyperlinks.Add Anchor:=Ws1.Cells(Sh_Sta + 1, "B"), Address:="", SubAddress:=Sh_Name & "!A1"
    
    'シートのA1セルが空の場合、「目次に戻る」を追加
    If Worksheets(Sh_Name).Cells(1, 1) = "" Then
    
        Ws1.Hyperlinks.Add Anchor:=Worksheets(Sh_Name).Cells(1, 1), Address:="", SubAddress:="目次!A1", ScreenTip:="ヒントを表示", TextToDisplay:="目次へ戻る"
        
    End If
    
    Sh_Sta = Sh_Sta + 1

Loop

Ws1.Activate

MsgBox "処理を終了します。", vbOKOnly + vbInformation, "正常終了"

End Sub

Sub 目次作成()

Dim Ws1 As Worksheet

Set Ws1 = Worksheets("目次")

'処理前に列情報をクリア

Columns(2).Clear

Ws1.Cells(2, "B") = "目次"

'選択したボタン名を取得

Dim Button_Name As String: Button_Name = ActiveSheet.Buttons(Application.Caller).Text

'シート追加を選択した場合

If Button_Name = "シート追加" Then

Dim Sh_Add As String: Sh_Add = InputBox("シート名を指定して下さい。", "シート名確認", "")

'追加シート名が未入力の場合は処理を止める

If Sh_Add = "" Then

MsgBox "シート名を設定してください。", vbYesNo + vbExclamation, "エラー"

Exit Sub

End If

'右端にシートを追加

Worksheets().Add After:=Worksheets(Worksheets.Count)

ActiveSheet.Name = Sh_Add

'目次へ戻るを設定

Ws1.Hyperlinks.Add Anchor:=Range("A1"), Address:="", SubAddress:="目次!A1", ScreenTip:="ヒントを表示", TextToDisplay:="目次へ戻る"

End If

'共通ルート

Dim Sh_Sta As Long: Sh_Sta = 2 'シート読込開始位置

Dim Sh_Name As String '読込シート名

Dim Sh_Cnt As Long: Sh_Cnt = Worksheets.Count 'シート数取得

'全シートを読み込むまで繰り返し

Do While Sh_Sta <> Sh_Cnt + 1

'目次シートに読み込んだシート名を設定

Sh_Name = Worksheets(Sh_Sta).Name

Ws1.Cells(Sh_Sta + 1, "B") = Sh_Name

'読み込んだシートのA1セルに飛ぶようにハイパーリンクを設定

Ws1.Hyperlinks.Add Anchor:=Ws1.Cells(Sh_Sta + 1, "B"), Address:="", SubAddress:=Sh_Name & "!A1"

'シートのA1セルが空の場合、「目次に戻る」を追加

If Worksheets(Sh_Name).Cells(1, 1) = "" Then

Ws1.Hyperlinks.Add Anchor:=Worksheets(Sh_Name).Cells(1, 1), Address:="", SubAddress:="目次!A1", ScreenTip:="ヒントを表示", TextToDisplay:="目次へ戻る"

End If

Sh_Sta = Sh_Sta + 1

Loop

Ws1.Activate

MsgBox "処理を終了します。", vbOKOnly + vbInformation, "正常終了"

End Sub