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