このような場合の処理方法を、「基本操作」の「枠取りした中の右上にページ数を表示」で使用したサンプルフォームを用いて紹介します。
(画像をクリックすると、このサンプルがダウンロードできます)
印刷上での「お体裁」になりますが、明細が数行の入力であっても印刷時にはページいっぱいのところまで罫線を引いてしまう例です。このサンプルでは枠線印刷になっており、実際に罫線を引くのではなく印刷範囲の変更を行なうだけで罫線(枠線)も印刷されます。
今回の処理は、印刷イベントにて起動させます。従って起動ボタンなどはありません。普通に「印刷」や「印刷プレビュー」を行なう時にデータの最終行を判定してそのページの最終行までを印刷範囲に変更します。
'***************************************************************************************************
' 定型書式でページ範囲いっぱいを印刷範囲にする ThisWorkbook(Class)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'03/06/07(1.00)新規作成
'20/02/06(1.10)*.xlsm化
'***************************************************************************************************
Option Explicit
'***************************************************************************************************
' ■■■ ワークブックイベント ■■■
'***************************************************************************************************
'* 処理名 :Workbook_BeforeClose
'* 機能 :閉じる前イベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = Cancel(Boolean) ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2020年02月06日
'* 作成者 :井上 治
'* 更新日 :2020年02月06日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'-----------------------------------------------------------------------------------------------
' ステータスバーメッセージをクリア
Application.StatusBar = False
End Sub
'***************************************************************************************************
'* 処理名 :Workbook_BeforePrint
'* 機能 :印刷処理前イベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = Cancel(Boolean) ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年06月07日
'* 作成者 :井上 治
'* 更新日 :2020年02月06日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Workbook_BeforePrint(Cancel As Boolean)
'-----------------------------------------------------------------------------------------------
' 印刷範囲設定
Call SET_PrintArea
' 処理確認
Application.StatusBar = "印刷範囲設定しました。"
' 保存済み状態にする
ThisWorkbook.Saved = True
End Sub
'----------------------------------------<< End of Source >>----------------------------------------
'***************************************************************************************************
' 定型書式でページ範囲いっぱいを印刷範囲にする Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'03/06/07(1.00)新規作成
'20/02/06(1.10)*.xlsm化、記述整理
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const cnsPrintArea = "$A$5:$H$"
'***************************************************************************************************
' ■■■ シート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :SET_PrintArea
'* 機能 :印刷範囲を余白いっぱいに取る処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年06月07日
'* 作成者 :井上 治
'* 更新日 :2020年02月06日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:アクティブなシートに対して作用します
'***************************************************************************************************
Sub SET_PrintArea()
'-----------------------------------------------------------------------------------------------
Dim xlApp As Application ' Excel.Application
Dim objSh As Worksheet ' Worksheet
Dim objWin As Window ' Window
Dim lngRow As Long ' 行INDEX
Dim lngRow2 As Long ' 行INDEX
Dim lngPage As Long ' ページ番号
Dim strErrMSG As String ' エラーメッセージ
' 各オブジェクトの参照を取得
Set xlApp = Application
Set objSh = ActiveSheet
Set objWin = ActiveWindow
' 画面描画を停止
With xlApp
.ScreenUpdating = False
.Cursor = xlWait
End With
On Error GoTo SET_PrintArea_ERROR
' ActiveSheetの処理
With objSh
' 現在、データがある最終行を取得
lngRow = .Range(cnsPrintArea & .Rows.Count).End(xlUp).Row ' ①
' 改頁プレビューに移行
objWin.View = xlPageBreakPreview ' ②
' 一旦、現在最終行より1頁分以上先を最終行にする
lngRow2 = lngRow + 200 ' ③
.PageSetup.PrintArea = cnsPrintArea & CStr(lngRow2)
' 改頁位置を調査し、データ最終行を超えた所までを判定
For lngPage = 1 To .HPageBreaks.Count ' ④
.HPageBreaks(lngPage).Location.Select
lngRow2 = Selection.Row - 1
If lngRow2 >= lngRow Then Exit For
Next lngPage
' 総ページ数をセット(H2セル)
.Cells(2, 8).Value = lngPage ' ⑤
' 判定した所までを印刷範囲とする
.PageSetup.PrintArea = cnsPrintArea & CStr(lngRow2) ' ⑥
' 通常ビューに戻る
objWin.View = xlNormalView ' ⑦
End With
' 終了
GoTo SET_PrintArea_EXIT
'===================================================================================================
' プリンタ未設定等エラー処置
SET_PrintArea_ERROR:
' メッセージのセット
strErrMSG = Err.Description
'===================================================================================================
' 終了
SET_PrintArea_EXIT:
' 画面描画を再開
With xlApp
.Cursor = xlDefault
.ScreenUpdating = True
End With
' メッセージがあれば表示
If strErrMSG <> "" Then
MsgBox strErrMSG, vbCritical
End If
On Error GoTo 0
End Sub
'***************************************************************************************************
'* 処理名 :CLEAR_PrintArea
'* 機能 :印刷範囲を見出しだけに戻す処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2003年06月07日
'* 作成者 :井上 治
'* 更新日 :2020年02月06日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:アクティブなシートに対して作用します
'***************************************************************************************************
Sub CLEAR_PrintArea()
'-----------------------------------------------------------------------------------------------
Dim xlApp As Application ' Excel.Application
Dim objSh As Worksheet ' Worksheet
' 各オブジェクトの参照を取得
Set xlApp = Application
Set objSh = ActiveSheet
objSh.Cells(2, 8).MergeArea.ClearContents
objSh.PageSetup.PrintArea = cnsPrintArea & "5"
End Sub
'----------------------------------------<< End of Source >>----------------------------------------