VBAでページ番号をつける

感想おまちしてます!

指定したエクセルファイルのページごとに通番をつけていくマクロ。複数のファイルに連番をつけたい時はこのマクロを使えばいい。

その他応用も可能なのでテンプレートに使用できる。

このマクロができること

  • ページ付与機能
  • ページ整形機能
スポンサーリンク

ソース一部抜粋

'連番で複数ファイルにページ番号を付与する
'分類を利用して作成しておく
Sub ページ番号付与実行()

Application.DisplayAlerts = False

処理続行確認メッセージ

Dim RowNum As Integer
Dim TotalPageNum As Integer
TotalPageNum = 0

'設定シート読込みループ
For RowNum = 5 To ActiveSheet.Cells.SpecialCells(xlLastCell).Row

'設定取得
エクセル文書整形設定取得 (RowNum)


If FilePath = "" Then
MsgBox "おわったよー", vbInformation, "終了"
Exit For
End If

Dim IsChange As Boolean
IsChange = False

If ClassA <> ClassABefore Or ClassB <> ClassBBefore Then
'大分類、中分類が変わった時
IsChange = True

If StartNum <> 0 And StartNum <> 1 Then
'開始番号が指定されている場合はその値を利用する
TotalPageNum = StartNum - 1
Else
TotalPageNum = 0
End If
End If

'MsgBox "StartNum=" & StartNum
'MsgBox "TotalPageNum=" & TotalPageNum

Workbooks.Open fileName:=FilePath
Worksheets(1).Activate

'設定する開始ページ番号を記入
ThisWorkbook.Sheets("設定").Cells(RowNum, 5).Value = TotalPageNum + 1

'シート選択
Dim W As Worksheet
For Each W In Worksheets

W.Select

With ActiveSheet

If W.Name Like TargetSheetInitial Then

'これまでの総ページ数 + 1 を設定する
.PageSetup.FirstPageNumber = TotalPageNum + 1
.PageSetup.RightFooter = "&""MSP ゴシック""&P"

'ヘッダの設定
ヘッダクリア

If HeaderStr <> "" Then
.PageSetup.RightHeader = HeaderStr
End If

'フッター設定
フッタクリア

If ClassA = "" Then
If ClassB = "" Then
.PageSetup.RightFooter = "&""MSP ゴシック""&P"
Else
.PageSetup.RightFooter = ClassB & Sep & "&""MSP ゴシック""&P"
End If
Else
If ClassB = "" Then
.PageSetup.RightFooter = ClassA & Sep & "&""MSP ゴシック""&P"
Else
.PageSetup.RightFooter = ClassA & Sep & ClassB & Sep & "&""MSP ゴシック""&P"
End If
End If

'総ページ数をカウントする
TotalPageNum = TotalPageNum + ページ数取得
'MsgBox "TotalPageNum=" & TotalPageNum
End If

End With
Next W

'総ページ数が処理後も同じならばページ番号を付与していない
If ThisWorkbook.Sheets("設定").Cells(RowNum, 5).Value - 1 = TotalPageNum Then
ThisWorkbook.Sheets("設定").Cells(RowNum, 5).Value = "-"
End If

'ページを付与したシートを全て選択しておく
Dim W2 As Worksheet
Dim IsFirst As Boolean
IsFirst = True

For Each W2 In Worksheets
If W2.Name Like TargetSheetInitial Then
If IsFirst Then
W2.Select True
IsFirst = False
Else
W2.Select False
End If
End If
Next W2

'上書き保存
ActiveWorkbook.Save
ActiveWorkbook.Close

Next RowNum

Application.DisplayAlerts = True

MsgBox "おわったよー", vbInformation, "終了"

End Sub