【Excel VBA】シートの一覧（ハイパーリンク付き）を作るマクロ

copy

Private Const SHEETNAME_MOKUJI As String = "目次"

Private Const COLNO_OUTPUT_NO As Long = 2
Private Const COLNO_OUTPUT_SHEETNAME As Long = COLNO_OUTPUT_NO + 1
Private Const ROWNO_HEADER As Long = 2

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 目次シートを作成する（こちらのマクロを実行します）
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub MakeMokujiSheet()

    Dim sheet As Worksheet
    
    ' 目次シートの初期化
    Call InitializeMokujiSheet
    
    Set sheet = Worksheets(SHEETNAME_MOKUJI)
    
    
    ' 目次を作成
    Call MakeMokuji(sheet)


End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' "一覧"シートがある場合にはいったん削除して、1シート目に作り直す
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub InitializeMokujiSheet()

    Dim ws As Worksheet
    
    For Each ws In Worksheets
    
        If ws.Name = SHEETNAME_MOKUJI Then
            
            ' "削除しますか？"の確認メッセージを非表示にする
            Application.DisplayAlerts = False
            
            ' "一覧"シートを削除する
            Worksheets(SHEETNAME_MOKUJI).Delete
            
            ' メッセージを表示する設定に戻す
            Application.DisplayAlerts = True
            
        End If
    
    Next ws
    
    ' 1シート目に"一覧"シートを作成する
    Worksheets.Add Before:=Worksheets(1)
    ActiveSheet.Name = SHEETNAME_MOKUJI

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 一覧を作成する
' テキスト：シート名、ハイパーリンク：各シートのA1セル
' 1シート目には"一覧"シートがあるため、2シート目から処理をする
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub MakeMokuji(ByVal sheet As Worksheet)
    
    Dim sheetCount, rowNoOutputData As Integer
    
    ' ヘッダーを設定する
    Call SetHeader(sheet)
    
            
    ' 一覧を出力する
    rowNoOutputData = ROWNO_HEADER
    
    For sheetCount = 2 To Worksheets.Count
    
        rowNoOutputData = rowNoOutputData + 1
        
        ' Noを設定
        sheet.Cells(rowNoOutputData, COLNO_OUTPUT_NO).Value = sheetCount - 1
        
        ' ハイパーリンクを設定
        sheet.Hyperlinks.Add Anchor:= _
            sheet.Cells(rowNoOutputData, COLNO_OUTPUT_SHEETNAME), _
            Address:="", _
            SubAddress:=Worksheets(sheetCount).Name & "!A1", _
            TextToDisplay:=Worksheets(sheetCount).Name
        
    Next
    
    
    ' 罫線を引く
    Call SetLineStyle(sheet, rowNoOutputData)

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ヘッダーを設定する
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub SetHeader(ByVal sheet As Worksheet)
    
    ' ヘッダーを出力する
    sheet.Cells(ROWNO_HEADER, COLNO_OUTPUT_NO).Value = "No"
    sheet.Cells(ROWNO_HEADER, COLNO_OUTPUT_SHEETNAME).Value = "シート名"
    
    ' ヘッダーに色を付ける
    sheet.Cells(ROWNO_HEADER, COLNO_OUTPUT_NO).Interior.Color = rgbLawnGreen
    sheet.Cells(ROWNO_HEADER, COLNO_OUTPUT_SHEETNAME).Interior.Color = rgbLawnGreen
    
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 罫線を引く
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub SetLineStyle(ByVal sheet As Worksheet, ByVal endRowno As Long)

    With sheet.Range(Cells(ROWNO_HEADER, COLNO_OUTPUT_NO).Address, Cells(endRowno, COLNO_OUTPUT_SHEETNAME)).Borders
        .LineStyle = xlContinuous
    End With

End Sub