とある台帳の目次シート（セル項目とその通しページ数をまとめたもの）をメンテ用に作成したマクロ
改ページを含んだシートで、各シート内のＢ行、Ｃ行に必要な項目（大項目、中項目）が点在していたので、これで機械的に通しページを拾えるのは大きい。
—-
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, j, k 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 ‘ Applicationオブジェクト
Dim intFF As Integer ‘ FreeFile値
Dim strFileName As String ‘ OPENするファイル名(フルパス)
Dim vntFileName As Variant ‘ ファイル名受取り用
‘ Applicationオブジェクト取得
Set xlAPP = Application
vntFileName = xlAPP.GetSaveAsFilename(InitialFileName:="result.txt", _
FileFilter:=cnsFilter, _
Title:=cnsTitle)
‘ キャンセルされた場合はFalseが返るので以降の処理は行なわない
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 homeWbk 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 Range(大項目検索範囲)
If c.Value <> "" Then
If i < 項目総数 Then
シート.大項目(i).項目名 = c.Value
シート.大項目(i).項目の場所 = c.Address
シート.大項目(i).ページ = getPageNumber(ws, Range(c.Address))
シート.大項目(i).通しページ = 目次.総ページ数 + シート.大項目(i).ページ
i = i + 1
End If
End If
Next c
i = 0
For Each c In Range(中項目検索範囲)
If c.Value <> "" Then
If i < 項目総数 Then
シート.中項目(i).項目名 = c.Value
シート.中項目(i).項目の場所 = c.Address
シート.中項目(i).ページ = getPageNumber(ws, Range(c.Address))
シート.中項目(i).通しページ = 目次.総ページ数 + シート.中項目(i).ページ
i = i + 1
End If
End If
Next c
Exit Sub
EXCEPTION:
Err.Source = "-> 目次情報取得2 " & Err.Source
Err.Raise (Err.Number & 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.Source = "-> 目次情報取得2 " & Err.Source
Err.Raise (Err.Number & Err.Source & Err.Description)
End Function
コメント