VBAでの改ページ位置の変更

Question

こんばんわ。

検索したり、自分でも考えてみたのですが、壺にハマっているようで、
どなたかお助けください。

Excelで以下の様な表があります。
営業所コード　部署　氏名　・・・（横幅はA4に収まるサイズです）
　　001　　　　001　AAA
　　001　　　　002　BBB
（コードに変化があるたびに、1行空白があります。）
　　002　　　　001　CCC
[------------------------] Ｏ
　　003　　　　001　DDD
　　003　　　　001　DDD
<------------------------> X
　　003　　　　002　EEE

このような表が縦にいくつも並びます。
印刷時にA4サイズの用紙からはみ出した部分について、
上記の「003」のような位置（Xの位置）に自動的に入ってしまう改ページを防ぎ、
003の一番上の行の上部(Ｏの位置)で改ページしたいのです。
何か良い方法はないでしょうか？

縦方向は集計のたびに変位するので、特定のルール化ができなくて困っています。

改ページ位置（行数）を取得して、その上のデータの可否をチェックしていくというのが、
Betterな方法なのでしょうか？
ページ数で20～30ページになるので、このループ処理が良いのかどうか。。。

Wendy02 · Accepted Answer

こんにちは。

＞どこか間違っていますでしょうか？

たぶん、コードの置いてある場所が、標準モジュールではなく、シートモジュールで、いくつかの条件が組み合わされば、Rangeオブジェクトのエラーは出ます。エラーが出ないように直しました。

それと、コードを見るまで、全体を縮尺を縮めるというのは、私の想像していたものとは、かなり違ってきますね。いろいろ試してみましたが、繰り返し行うせいでしょうか、PageBreaksで取れる行が不安定ですね。以下は、垂直改ページを取るサブルーチンを加えてみました。なお、物理的水平改ページは、どんなに改ページReset しても、残りますから、1ページ1行しかないところが出てくることはあります。


Sub HBreake_Aligment2()
　 Dim myPrintArea As String
　 Dim DefaultPageRow As Integer
　 Dim LastRow As Long
　 Dim PreRow As Long
　 Dim cnt As Integer
　 Dim NewRow As Long
　 With ActiveSheet
　　　If .PageSetup.PrintArea = "" Then
　　　　 MsgBox "印刷範囲を設定してください", 16
　　　　 Exit Sub
　　　　 Else
　　　　 myPrintArea = .PageSetup.PrintArea
　　　　 LastRow = .Cells(65536, .Range(myPrintArea).Column).End(xlUp).Row
　　　　 If .Range(myPrintArea).Cells(.Range(myPrintArea).Count).Row > LastRow Then
　　　　　　.PageSetup.PrintArea = .Range(myPrintArea).Resize(LastRow).Address(0, 0)
　　　　 End If
　　　End If
　　　.ResetAllPagereaks
　　　'サブルーチン
　　　Call VPageDragoff
　　　Application.ScreenUpdating = False
　　　DefaultPageRow = _
　　　Application.ExecuteExcel4Macro("(INDEX(GET.DOCUMENT(64),1," & 1 & "))")
　　　PreRow = DefaultPageRow
　　　Do
　　　　 NewRow = MyNewRowFind(PreRow)
　　　　 .HPageBreaks.Add .Cells(NewRow, 1)
　　　　 PreRow = NewRow + DefaultPageRow
　　　Loop Until PreRow > LastRow
　　　Application.ScreenUpdating = True
　　　.PrintOut Preview:=True
　 End With
End Sub
'
Private Function MyNewRowFind(ByVal myRow As Long)
Dim j As Long
Dim flg As Boolean
　With ActiveSheet
　 '25行前まで探す
　 For j = myRow - 1 To myRow - 25 Step -1
　　　If .Cells(j, 1).Value = "" Then
　　　　flg = True
　　　　 Exit For
　　　End If
　 Next j
　 If myRow > j + 1 And flg Then
　　MyNewRowFind = j + 1
　 Else
　　MyNewRowFind = myRow
　 End If
　End With
End Function

Sub VPageDragoff()
'垂直改ページのドラッグオフ
Dim myVbp As Integer
With ActiveSheet
　　Application.ScreenUpdating = False
　　　.PageSetup.Zoom = 100
　　myVbp = ExecuteExcel4Macro("COLUMNS(GET.DOCUMENT(65))")
　　If myVbp > 1 Then
　　　ActiveWindow.View = xlPageBreakPreview
　　　.VPageBreaks(1).DragOff xlToRight, 1
　　　ActiveWindow.View = xlNormalView
　　End If
End With
　　Application.ScreenUpdating = True
End Sub

imogasi · Answer

１ページに印刷できる行数（行高などが影響する）を、実際印刷してみて、何号印刷できるか、格好が良いかの行数を得ます。
そしてプログラムで、キーとなる営業所コードが変わるまでの件数（行数）を勘定し、ページの初めから直前までの行数和＋今の営業所行数＞一定数なら、今の営業所の明細を、全行数とも、そのページに詰め込むことをあきらめて、今までの行を印刷し、今の営業所の行全体を次ページの初めから印刷する。
誰でも考え付くロジックだと思いますが、これではどうですか。
上記のためには書く明細行の行高は皆一定でないと出来にくいですが。

Wendy02 · Answer

こんばんは。

　VBAでも、どちらかというと、これは難しい部類ですね。（私のVBAの勉強の初期の頃に出会ったものです。私は失敗から－プロの人や上級の人なら周知のことから、現在のようなテクニックを使っています。VBAでは、改ページデータが取れなくなるというトラブルがあります。）

　改行には、二種類あります。1つは、自動改ページです。それが、現在　kentonさんがおっしゃっている「X」 の部分です。次に、「○」の部分のことを、手動改ページといいます。

私の考えたコードです。ただし、ロジックを確認していませんので、もし、違うようだったら、また別なものを考えます。マクロコードが終わったら、改ページプレビューで確認してください。

'<標準モジュール推奨>
Sub HBreake_Aligment()
Dim myRow As Long
Dim NewRow As Long
Dim TotalHpage As Integer
Dim i As Long
With ActiveSheet
　　　If .PageSetup.PrintArea = "" Then
　　　　 MsgBox "印刷範囲を設定してください", 16
　　　　 Exit Sub
　　　End If
　　　.ResetAllPageBreaks
　　TotalHpage = Application.ExecuteExcel4Macro("COLUMNS(INDEX(GET.DOCUMENT(64),0,0))")
　For i = 1 To TotalHpage
　 myRow = Application.ExecuteExcel4Macro("(INDEX(GET.DOCUMENT(64),1," & i & "))")
　 NewRow = MyNewRowFind(myRow)
　 .HPageBreaks.Add .Cells(NewRow, 1)
　Next i
End With
　Beep '終了合図
End Sub
'
Private Function MyNewRowFind(myRow As Long)
　 Dim j As Long
　With ActiveSheet
　 For j = myRow + 1 To 20 Step -1
　　　If .Cells(j, 1).Value = "" Then
　　　　 Exit For
　　　End If
　 Next j
　 If myRow > j + 1 Then
　　MyNewRowFind = j
　 Else
　　MyNewRowFind = myRow
　 End If
　End With
End Function

　このコードの考え方は、自動改ページをまず探して、それより手前（行の若い方の番号）で、「（コードに変化があるたびに、1行空白があります。）」行を探します。20まで遡っても見つからなかったら、それは、もう自動改ページのままにし、そうでないなら、その空白値の行番号を、戻して、手動改ページにする、というものです。

なお、20行遡るのが最適か分りませんが、通常1ページ50行～60行の間ですから、ある程度の適当に割り振りしました。また、縦改行(VPageBreak)については考慮されていません。

参考サイト（以下のサイトの中の「注意」が、トラブルのことです。だから、そのコードでは、無条件ではうまくいかないということです。）

[XL2002] 印刷されるページの総数を調べる方法
http://support.microsoft.com/default.aspx?scid=kb;ja;408042

takibo · Answer

ちょっとひねくれた方法かもしれませんがいかがでしょうか？
表自体を印刷するのではなく、印刷用の表に一定の範囲を複写して印刷していきます。

ごくごく簡単なコードを作ってみました。
Sub 印刷()
　With Sheets(1)
　　LR = .Range("A65536").End(xlUp).Row
　　i = 1
　　Do Until i > LR
　　　If .Cells(i, 1).Value = "" Then i = i + 1
　　　j = i + 50
　　　If .Cells(j, 1) <> "" Then
　　　　For m = j - 1 To i Step -1
　　　　　ER = m
　　　　　If .Cells(m, 1).Value = "" Then
　　　　　　ER = m
　　　　　　Exit For
　　　　　End If
　　　　Next
　　　　If ER = i Then ER = j - 1
　　　Else
　　　　ER = j - 1
　　　End If
　　　Range(.Cells(i, 1), .Cells(ER, 10)).Copy Destination:=Sheets(2).Range("A1")
　　　Sheets(2).PrintOut
　　　Sheets(2).Cells.ClearContents
　　　i = ER + 1
　　Loop
　End With
End Sub

【解説】
データのあるシートを[Sheets(1)]とし、印刷用の定形シート[Sheets(2)]を用意します。これを50行・A4 1枚に出力と設定したとします。

データの最終行を取得し、1行めから50行ずつコピーしていきます。その際の処理分岐として
(1)51行目が空白の場合 → 1行めから50行目をコピー
(2)51行目が空白で無い場合、1行ずつさかのぼって行き
　　(a)空白行があればその行までをコピー
　　(b)空白行がなければ、1行めから50行目をコピー

分岐の判断としては
(1)ちょうど50行目でデータが区切られた場合
(2)-(a)50行目がデータの途中で、それより上の範囲にデータ区切りが存在する場合
(2)-(b)1行めから50行目までデータが連続している場合
としています。

>３．1行の行高が一定でない場合がある（横幅を抑えるためセル内で改行あり）
このケースには対応しきれていないので修正が必要かと思われます。

Wendy02 · Answer

こんにちは。
kentonさん、もう一度、考え直しておりますから、閉めないでくださいね。

＞手動改ページ設定ののち、４ページに増えた場合に、
最終ページが作表された部分を切り分けてしまいました。

これが、良く再現できていないのですが、ただ、コードとして、#2の私の書いたものは、不具合があることは分りました。

Wendy02 · Answer

こんばんは。
間を開けてすみません。プリンタをついに修理に出した関係で、後回しにしてしまっているのです。Preview モードにすれば同じなのですが（^^;

私ごとですが、自分の書いたところが、締切になるまでは、きちんと、チェックできるように、また、受付中だけ、オートフィルタで出して、ここのページに直接飛べるように、VBAで組んでありますので、忘れることはしません。

＞既に倍率が78％になった状態で処理を施しているので、
＞それが原因かもしれません。

あくまでも、私のコードの計算がおかしいというのはわかっているのです。本日、気を取り直してやっていたのですが、ステップモードで動かしている内に、暗算でしていると、改行は、+1 なのか　-1　なのか、というところで、計算がごちゃごちゃになってしまいました。

それで、ともかく、最初に、(水平）ページ数を取るというのは、間違いなんだなっていうことが分ったのです。Do ～ While で、増加しても、最後のページの処理をしない、というところまでは出来ているのですが、その中間値の改ページの足し算・引き算がはっきりしなくなったということです。それは、改ページプレビューで、ちょっとヘンな出方をしているので、どうも、今日中、出すわけにはいけないことになってしまいました。（言い訳じみてすみません）

それから、
お勧めはしませんが、Excel 4.0 マクロ関数(ExecuteExcel4Macro)の情報については、以下のところで得られます。英語のみです。他のヨーロッパ言語はあるようですが、日本語の場合は、以前のものは、テクニカル・ライターが特別に書いたものだったようで、新しいヘルプファイルまでは、力を掛けなかったようです。

http://office.microsoft.com/ja-jp/assistance/HP010475331041.aspx

ダウンロードして、ヘルプファイルを取り出せばよいのです。展開すると、場所は、
C:\Program Files\Microsoft Office\Office\1033\ に入るので、それを単独で、閲覧すればよいのですが、中身が英語だったりして、ちょっと、面倒かもしれませんね。
もう、使われることはない過去の遺物には違いないのですが、マクロ関数(ExecuteExcel4Macro）は、C言語で作られていることと、Excel Application に直接アクセスすることで、VBAから、オブジェクトを通しているわけではないので、その分だけ、検索が速いのです。ブレも少ないようです。

私の場合は、マニュアルを持っていますが、ほとんど、決められたものしか使っていません。ちなみに、今回のこのマクロ関数を使う方法は、二年ぐらい前に、日経PC21などで、有名な方が使っていた方法です。何度も、改ページを繰り返してみて、通常のVBAでは、改ページデータが、飛んでしまうことに気が付きました。

もう少々、お待ちください。

Wendy02 · Answer

kentonさん、大変お待たせしてすみませんでした。

一応、修正してみました。

'<標準モジュール推奨>
Sub HBreake_Aligment1()
Dim DefaultPageRow As Integer
Dim LastRow As Long
Dim PreRow As Long
Dim cnt As Integer
Dim NewRow As Long
With ActiveSheet
　　　If .PageSetup.PrintArea = "" Then
　　　　 MsgBox "印刷範囲を設定してください", 16
　　　　 Exit Sub
　　　End If
　　　LastRow = Range(.PageSetup.PrintArea).SpecialCells(xlCellTypeLastCell).Row
　　　.ResetAllPageBreaks
　DefaultPageRow = Application.ExecuteExcel4Macro("(INDEX(GET.DOCUMENT(64),1," & i & "))")
　PreRow = DefaultPageRow
　Do
　　NewRow = MyNewRowFind(PreRow)
　 .HPageBreaks.Add .Cells(NewRow, 1)
　 PreRow = NewRow + DefaultPageRow
　Loop Until PreRow > LastRow
　.PrintOut Preview:=True
End With
End Sub
'
Private Function MyNewRowFind(ByVal myRow As Long)
Dim j As Long
Dim flg As Boolean
　With ActiveSheet
　 For j = myRow - 1 To myRow - 21 Step -1
　　　If .Cells(j, 1).Value = "" Then
　　　　flg = True
　　　　 Exit For
　　　End If
　 Next j
　 If myRow > j + 1 And flg Then
　　MyNewRowFind = j + 1
　 Else
　　MyNewRowFind = myRow
　 End If
　End With
End Function

Wendy02 · Answer

kenton様。
こんばんは。
一応、ここは、毎日チェックをしておりますが、修正版は、いかがなものでしょうか？定番マクロなのですが、今回は、大きさの変更が入りましたので、マクロの自動改行が、ひじょうに不安定な状態になることは、やむを得ないことをご承知ください。

VBAでの改ページ位置の変更

１ページに印刷できる行数（行高などが影響する）を、実際印刷してみて、何号印刷できるか、格好が良いかの行数を得ます。

こんばんは。

この回答への補足

ちょっとひねくれた方法かもしれませんがいかがでしょうか？

こんにちは。

こんばんは。

kentonさん、大変お待たせしてすみませんでした。

この回答への補足

こんにちは。

kenton様。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング