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

質問

こんばんわ。

検索したり、自分でも考えてみたのですが、壺にハマっているようで、
どなたかお助けください。

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ページになるので、このループ処理が良いのかどうか。。。

回答No.7

Wendy02 · ベストアンサー

こんにちは。

＞どこか間違っていますでしょうか？

たぶん、コードの置いてある場所が、標準モジュールではなく、シートモジュールで、いくつかの条件が組み合わされば、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

回答No.8

Wendy02

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

お礼

Wendy02さん、ご報告が遅れて申し訳ありませんでした。

その後、前回のマクロにて実験を重ねてみました。
やはり、大きさの変更があるからでしょうか、自動改行位置が不規則になることがありまして、
結論は、用紙の仕様を変更してもらい、
縦方向のみの自動改行とすることでクリアとしていただきました。
納期の関係で”遅れ”の方がマズイと・・・（^^;）

せっかくWendy02さんに教えていただいたこともありますので、
運用するかどうかとは別に、個人的に処理を再度検討していこうと考えています。
お礼が遅れておきながらですが、
また、別の件で見かけることがありましたら、
回答を付けていただけると助かります。

それにしても、新しくなったOKWaveは・・・^^;

回答No.6

Wendy02

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さん、度々ありがとうございます。
そして、お返事遅れて申し訳ありません。

ソースを参考に、適用してみました。
結果、
「LastRow = Range(.PageSetup.PrintArea).SpecialCells(xlCellTypeLastCell).Row」
の箇所でエラー（Rangeメソッドの失敗）となってしまいまして、
その原因となるPrintAreaの設定で四苦八苦しております。

現在、横幅の範囲を先に設定する（印刷範囲に収まるよう縮小）ために以下のソースをモジュール「HBreake_Aligment1」の前に処理しています。
Sub VerticalSetUp()
'プリントエリアの拡大設定
ActiveSheet.PageSetup.Zoom = 100
'設定
ActiveWindow.View = xlPageBreakPreview
ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
ActiveWindow.View = xlNormalView
End Sub

この操作で、PrintArea自体は設定が完了しているものと認識しているのですが、
どこか間違っていますでしょうか？
また、お暇がありましたら、回答を付けていただけると幸いです。

回答No.5

Wendy02

こんばんは。
間を開けてすみません。プリンタをついに修理に出した関係で、後回しにしてしまっているのです。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さん、おはようございます。

私も間をあけてしまうことが多いので、全然構いませんよ。
Wendy02さんの負担にならない程度でお願いいたします。

＞受付中だけ、オートフィルタで出して、
＞ここのページに直接飛べるように、VBAで組んでありますので、忘れることはしません。
こういうこともVBAでできちゃうんですね。
そのような仕組みをVBAで考えることもしたことなかったです。(^_^;)

実際に、私の方でも動作を見てみているのですが、
正直なところ、ロジックのどこをどう直すべきかわかりませんでした。

Excel 4.0マクロのヘルプもありがとうございます。
OfficeOnlineにあったんですね。
英語がそれほど得意ではないので、読みこなせるか不安ですが、頑張ってみます。

お手数をかけて申し訳ありませんが、まだ閉じずにお待ちしております。

回答No.4

Wendy02

こんにちは。
kentonさん、もう一度、考え直しておりますから、閉めないでくださいね。

＞手動改ページ設定ののち、４ページに増えた場合に、
最終ページが作表された部分を切り分けてしまいました。

これが、良く再現できていないのですが、ただ、コードとして、#2の私の書いたものは、不具合があることは分りました。

お礼

Wendy02さん、たびたびありがとうございます。

終了しなくて良かった　と思える瞬間です。
私が改良しようと考えていることを一緒に考えてくださってくださる方が、いるという・・・

＞最終ページが作表された部分を切り分けてしまいました。
そうなんです。
1ページ当りに入る表が少なくなった分、
印刷ページ数が増加すると、最終ページをまたぐ表が出てきます。
例）自動改ページで印刷3ページに収まるサイズの表を、
Wendy02さんの示してくださったソース（私が例示した条件「表がページをまたがない」での処理を行った）で処理を行うと、
4ページの印刷エリアが必要となり、3～4ページ目に表が分かれてしまう。

こちらでは、先に横の改ページを手動で設定しているため、
既に倍率が78％になった状態で処理を施しているので、
それが原因かもしれません。
明日以降、試してみます。

回答No.3

takibo

ちょっとひねくれた方法かもしれませんがいかがでしょうか？
表自体を印刷するのではなく、印刷用の表に一定の範囲を複写して印刷していきます。

ごくごく簡単なコードを作ってみました。
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行の行高が一定でない場合がある（横幅を抑えるためセル内で改行あり）
このケースには対応しきれていないので修正が必要かと思われます。

お礼

takiboさん、ご回答ありがとうございました。

ふむふむ。こういう手法も考えられましたね。
何故、気付かなかったんだろう・・・（＾＾；）

ただ、User側の操作を考えると、ステップが増えるため、
今回はWendy02さんのソースを拝借いたしました。

こういうことを一緒に考え、アドバイスをくれる人が傍にいてくれれば、
どんなに心強いか・・・

回答No.2

Wendy02

こんばんは。

　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

お礼

Wendy02さん、ご回答ありがとうございます。
更にソースまで、ありがとうございます。大変参考になります。

「改ページ位置（行数）を取得して、その上のデータの可否をチェックしていくというのが、Betterな方法なのでしょうか？」
こちらのパターンに近いでしょうか。
なかなか処理的には考えることが多そうですね。

まだ、実際に組み込んで動かしてはいないので、
動作実績をお伝えできないのですが、
「ExecuteExcel4Macro」という箇所がいまいち理解できないので、これから調べてみます。

参考URLも読んでみます。

補足

お礼欄に先に書いてしまいましたので、
補足欄で失礼します。

結論から申しますと、Wendy02さんのソースでほぼ実現ができました。
ありがとうございます。

「ほぼ」と書いた部分は、
自動改ページが、設定されている初期段階で３ページだったものが、
手動改ページ設定ののち、４ページに増えた場合に、
最終ページが作表された部分を切り分けてしまいました。
現在は、２度実行をすることで回避していますが、
他のロジックも考えています。

ちなみにExecuteExcel4Macroは、今回初めて知ったのですが、
引数（？）の情報とかが少なく調べ切れませんでした。
まだまだ、VBAも奥が深いです。。。

回答No.1

imogasi

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

お礼

imogasiさん、ご回答ありがとうございます。

imogasiさんの仰るロジック、良いですね。
私は思いつきませんでしたが(^_^;)
当たり前のことができていないというか・・・(-_-#)

質問文に全ての条件を書いていなかった私が悪いのですが、
１．1ページ目のみ表題が入る
２．印刷するプリンタメーカーが数種類あるため、
印刷範囲に収まる行数が一定ではない
３．1行の行高が一定でない場合がある（横幅を抑えるためセル内で改行あり）
などにより、他の処理が必要になります。

この辺りも含めて、もう一度考えてみます。