【Excel VBA】セル単位の目次作成用の情報収集マクロ

台帳の目次シート（セル項目とその通しページ数をまとめたもの）をメンテナンス用に作成したExcel VBAマクロです。

改ページを含んだシートで、各シート内のB列・C列に必要な項目（大項目、中項目）が点在している場合でも、自動的に通しページを取得して情報収集できます。

Option Explicit

'検索範囲
Const 大項目検索範囲 As String = "B1:B1000"
Const 中項目検索範囲 As String = "C1:C1000"

Type 項目情報
    項目名 As String
    ページ As Integer
    通しページ As Integer
    項目の場所 As String
End Type

Const 項目総数 As Integer = 5
Type シート情報
    シート名 As String
    ページ数 As Integer
    大項目(項目総数) As 項目情報
    中項目(項目総数) As 項目情報
End Type

Const シート総数 As Integer = 5
Type 目次情報
    総ページ数 As Integer
    シート数 As Integer
    シート(シート総数) As シート情報
End Type

Dim 目次 As 目次情報
Dim 初期化値 As 目次情報

Sub デバッグ表示(ByRef 目次 As 目次情報)
    Dim msg As String
    Dim i As Integer, j As Integer
    
    msg = "総ページ数=" & 目次.総ページ数 & "　シート数=" & 目次.シート数 & vbCrLf
    
    For i = 0 To 目次.シート数 - 1
        msg = msg & "　シート名=" & 目次.シート(i).シート名
        msg = msg & "　ページ数=" & 目次.シート(i).ページ数
        
        msg = msg & "----大項目-----" & vbCrLf
        For j = 0 To 項目総数
            msg = msg & "　　項目名=" & 目次.シート(i).大項目(j).項目名
            msg = msg & "　項目の場所=" & 目次.シート(i).大項目(j).項目の場所
            msg = msg & "　ページ=" & 目次.シート(i).大項目(j).ページ
            msg = msg & "　通しページ=" & 目次.シート(i).大項目(j).通しページ & vbCrLf
        Next j
        
        msg = msg & "----中項目-----" & vbCrLf
        For j = 0 To 項目総数
            msg = msg & "　　項目名=" & 目次.シート(i).中項目(j).項目名
            msg = msg & "　項目の場所=" & 目次.シート(i).中項目(j).項目の場所
            msg = msg & "　ページ=" & 目次.シート(i).中項目(j).ページ
            msg = msg & "　通しページ=" & 目次.シート(i).中項目(j).通しページ & vbCrLf
        Next j
    Next i
    
    Debug.Print msg
    テキスト出力 msg
End Sub

Sub テキスト出力(ByVal strREC As String)
    Const cnsTitle = "テキストファイル出力処理"
    Const cnsFilter = "テキストファイル (*.txt;*.dat),*.txt;*.dat"
    Dim xlAPP As Application
    Dim intFF As Integer
    Dim strFileName As String
    Dim vntFileName As Variant
    
    Set xlAPP = Application
    vntFileName = xlAPP.GetSaveAsFilename(InitialFileName:="result.txt", _
                                         FileFilter:=cnsFilter, _
                                         Title:=cnsTitle)
    If VarType(vntFileName) = vbBoolean Then Exit Sub
    strFileName = vntFileName

    intFF = FreeFile
    Open strFileName For Output As #intFF
    Print #intFF, strREC
    Close #intFF
    MsgBox "ファイル出力が完了しました。", vbInformation, cnsTitle
End Sub

Sub 目次情報取得()
    On Error GoTo EXCEPTION
    
    Dim TrgWbk As Workbook
    Dim ws As Worksheet
    Dim i As Integer
    
    目次 = 初期化値
    i = 0
    Set TrgWbk = ActiveWorkbook
    
    目次.シート数 = TrgWbk.Worksheets.Count
    For Each ws In TrgWbk.Worksheets
        ws.Activate
        ActiveWindow.View = xlPageBreakPreview
        
        Call 目次情報取得2(目次.シート(i), ws)
        目次.総ページ数 = 目次.総ページ数 + ws.PageSetup.Pages.Count
        
        i = i + 1
    Next ws

    Call デバッグ表示(目次)
    Exit Sub

EXCEPTION:
    Call MsgBox(Err.Number & " " & Err.Source & " " & Err.Description)
End Sub

Sub 目次情報取得2(ByRef シート As シート情報, ByVal ws As Worksheet)
    On Error GoTo EXCEPTION
    
    Dim i As Integer
    Dim c As Range
    
    シート.シート名 = ws.Name
    シート.ページ数 = ws.PageSetup.Pages.Count
    i = 0
    For Each c In ws.Range(大項目検索範囲)
        If c.Value <> "" Then
            If i < 項目総数 Then
                シート.大項目(i).項目名 = c.Value
                シート.大項目(i).項目の場所 = c.Address
                シート.大項目(i).ページ = getPageNumber(ws, c)
                シート.大項目(i).通しページ = 目次.総ページ数 + シート.大項目(i).ページ
                i = i + 1
            End If
        End If
    Next c
    
    i = 0
    For Each c In ws.Range(中項目検索範囲)
        If c.Value <> "" Then
            If i < 項目総数 Then
                シート.中項目(i).項目名 = c.Value
                シート.中項目(i).項目の場所 = c.Address
                シート.中項目(i).ページ = getPageNumber(ws, c)
                シート.中項目(i).通しページ = 目次.総ページ数 + シート.中項目(i).ページ
                i = i + 1
            End If
        End If
    Next c
    
    Exit Sub
EXCEPTION:
    Err.Raise Err.Number, "目次情報取得2->" & Err.Source, Err.Description
End Sub

Public Function getPageNumber(ByVal ws As Worksheet, ByVal TargetCell As Range) As Long
    On Error GoTo EXCEPTION
    Dim HPB As HPageBreak
    Dim m As Long

    For Each HPB In ws.HPageBreaks
        If HPB.Location.Row > TargetCell.Row Then Exit For
        m = m + 1
    Next
    getPageNumber = m + 1
    
    Exit Function
EXCEPTION:
    Err.Raise Err.Number, "getPageNumber->" & Err.Source, Err.Description
End Function