エクセルVBA業務ツール 多用途目次シートを自動増設する

Option Explicit

'解説１
Function Flag() As Boolean
    Dim ws As Worksheet
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = "もくじシート" Then
                Flag = True
                Exit For
            Else
                Flag = False
            End If
        Next
End Function


'解説２
Sub シート一覧()
    Dim s, i, BorRow As Long
    Dim mySheetName() As String
        If Flag = False Then
            ThisWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = "もくじシート"
        End If
        Worksheets("もくじシート").Select
        With Worksheets("もくじシート")
            With .Cells
                .Clear
                .Font.Bold = True
                .Font.Size = 13
            End With
            .Columns(1).HorizontalAlignment = xlCenter
            .Range("A2") = "NO."
            .Range("B2") = "シート名称"
            .Range("A1") = "シートもくじからそのシートにジャンプできます。"
            With .Range("A1:B2")
                .Font.ColorIndex = 5
                .Font.Size = 15
            End With
        ReDim mySheetName(1 To Worksheets.Count)      '
            For i = 1 To Worksheets.Count
                mySheetName(i) = Worksheets(i).Name
                .Range("A" & i + 2) = i
                .Range("B" & i + 2) = mySheetName(i)
            Next i
            With .Cells(1, 1).CurrentRegion
                BorRow = .Rows(.Rows.Count).Row
                .Offset(1).Resize(BorRow - 1, 2).Borders.LineStyle = True
                .Columns(2).AutoFit
            End With
            With .Range("A1")
                .HorizontalAlignment = xlLeft
                .Select
            End With
        End With
End Sub


'解説３
Sub シートジャンプ()
    Dim shRow As Long
    Dim SV As String
    Dim ws As Worksheet
    Dim Flagn As Boolean
        If Flag = False Then
            MsgBox "もくじシートがまだ作成されていません。"
            Exit Sub
        End If
    
            Worksheets("もくじシート").Select
            shRow = Cells(Rows.Count, 2).End(xlUp).Row
            If ActiveCell.Row < shRow + 1 And ActiveCell.Column = 2 Then
                SV = ActiveCell.Value
                If SV = "もくじシート" Then
                    Exit Sub
                Else
                    For Each ws In Worksheets
                        If ws.Name = SV Then Flagn = True
                    Next ws
                    If Flagn = True Then
                        Worksheets(SV).Select
                        Range("A1").Select
                    Else
                        MsgBox SV & "　シートは存在しません。", vbInformation, "メッセージ"
                    End If
                End If
            End If
End Sub


'解説４
Sub シートを削除()
Dim ActSh As String
Dim Ans As Long
Dim DelRow, n As Long
    If Flag = False Then
        MsgBox "もくじシートがまだ作成されていません。"
        Exit Sub
    End If
    ActSh = ActiveSheet.Name
    Ans = MsgBox("削除しようとしているシートは、「 " & ActSh & " 」です。" _
        & vbCrLf & "削除しますか？", vbYesNo + vbExclamation, "削除許可申請")
    If Ans = vbNo Then
        Exit Sub
    ElseIf Ans = vbYes Then
        If ActSh = "もくじシート" Then
            MsgBox "もくじシートは削除出来ません。"
        Else
        
            Worksheets(ActSh).Delete
            Worksheets("もくじシート").Select
            With Cells(1, 1).CurrentRegion
                DelRow = .Rows(.Rows.Count).Row
            End With
            For n = 3 To DelRow
                If Cells(n, 2) = ActSh Then
                    Cells(n, 2).ClearContents
                End If
            Next n
        End If
    End If
End Sub

Option Explicit


'解説５
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        MsgBox "機能の性質上このボタンでは終了出来ません。"
        Cancel = True
    End If
End Sub

Private Sub シート削除_Click()
Call Module1.シートを削除
End Sub

Private Sub シート表示_Click()
Call Module1.シートジャンプ
End Sub

Private Sub もくじシート更新_Click()
Call Module1.シート一覧
End Sub

Option Explicit

Private Sub Workbook_Open()
    目次コントロール.Show vbModeless
End Sub