マクロで改ページごとに印刷タイトルを移動

質問

①改ページプレビューを見ていくと最終ページまで各ページ148行分の表みたいなものがありその先頭1行目から4行目に4行一組の見出しタイトルとしたものが必ず入っていくようにするのですが、そのタイトル4行一組は行間隔が途中不規則に出現しますので、その際に148行目と149行目の改ページ境界線をタイトルがまたいでしまう場合があります。
次の②～⑤のパターンがそうですが
この時は強制的に次のページの先頭行に4行一組ごと強制移動していって送った分の行は空白のままになります。(基準148行から1行～4行分少ないページも出来るわけです)
⑥はページ内にタイトル4行が2種類以上～有る場合は最も下部のタイトル4行ごと次ページの先頭行にも同じものをコピペしていって行ってください
そこで4行一組の切り替わり基準の見分け方なのですがA列において一番上の行が「○○年」と「前〇〇〇」〇＝は数字4桁までで一番下の行が「生」という一文字が入っています
色帯は適当に選択してしまったので色番号が不明ですが大まかな色は上からグレー→黄色→黄緑→青の順です
図の一番下に参考があります
質問内容が意味不明でしたら諦めます
手作業の繰り返しでやると19万行以上1278ページあり大変です
下方に行数がどんどんスライドしていく分、さらに増えていきます

回答No.28

HohoPapa · ベストアンサー

>(2)　
>tgRng.Borders.ThemeColor = 1のところで
>実行時エラー'91'
>オブジェクト 変数 またはWith ブロック変数が
>設定されていませんと出ました

この問題、私がボケをかましていました。　(-_-)
罫線を引いているコード部分を以下の内容に置き換えてみてください。

Sub LinesSet(LastRow As Long)

　Dim r As Long

　'範囲全体に罫線を引く
　ShPut.Range("A1:D" & LastRow).Borders.LineStyle = True

　'ページ末に空行があったら､空白範囲の罫線を白に変更
　r = 148
　Do
　　If r > LastRow Then Exit Do

　　If ( _
　　　(ShPut.Cells(r - 3, 1) = "") And _
　　　(ShPut.Cells(r - 3, 2) = "") And _
　　　(ShPut.Cells(r - 3, 3) = "") And _
　　　(ShPut.Cells(r - 3, 4) = "")) Then
　　　Range(ShPut.Cells(r - 3, 1), ShPut.Cells(r, 4)).Borders.ThemeColor = 1
　　ElseIf ( _
　　　(ShPut.Cells(r - 2, 1) = "") And _
　　　(ShPut.Cells(r - 2, 2) = "") And _
　　　(ShPut.Cells(r - 2, 3) = "") And _
　　　(ShPut.Cells(r - 2, 4) = "")) Then
　　　Range(ShPut.Cells(r - 2, 1), ShPut.Cells(r, 4)).Borders.ThemeColor = 1
　　ElseIf ( _
　　　(ShPut.Cells(r - 1, 1) = "") And _
　　　(ShPut.Cells(r - 1, 2) = "") And _
　　　(ShPut.Cells(r - 1, 3) = "") And _
　　　(ShPut.Cells(r - 1, 4) = "")) Then
　　　Range(ShPut.Cells(r - 1, 1), ShPut.Cells(r, 4)).Borders.ThemeColor = 1
　　ElseIf ( _
　　　(ShPut.Cells(r, 1) = "") And _
　　　(ShPut.Cells(r, 2) = "") And _
　　　(ShPut.Cells(r, 3) = "") And _
　　　(ShPut.Cells(r, 4) = "")) Then
　　　Range(ShPut.Cells(r, 1), ShPut.Cells(r, 4)).Borders.ThemeColor = 1
　　End If
　　r = r + 148

　Loop

End Sub

お礼

おめでとうございます
最後だった(2)の問題も修正により
完全完璧に動作OKになり
しないよりは断然見栄えがすっかり向上しました
マクロ実行時間は当初より大幅に短縮され、ほんの2～3分で終了致しました
とても同じパソコンで処理したとは思えません
マクロの記述如何によっては、ここまで違うものかと驚嘆しました
またコード記述の恐ろしさの半面、完了した時の感激は
誠に気持ちがいいものです
エラーメッセージを早くから提供すればよかったものの曖昧な表現をしてしまいすいませんでした
図書館に寄付したいぐらいのデータベースになり
およそ延べ40万名を超える1375頁の資料本になりました
これにて終了になりましたが長々とお付き合い頂き感謝の念でいっぱいであります
またご覧に供しておられるか分りませんが最初に当方の質問にご検討いただいたkkkkkm様にもこの場をお借りして感謝致します。

回答No.7

kkkkkm

訂正です
何組目が駄目で
は
跨ぐ組が何組目かで

回答No.6

kkkkkm

回答No.4の補足を見る前に回答No.5を投稿したのですが

最初の4行は4行一組が必ずあると思うので、調査は5行目からとして

以下のようにしてください。

For i = 5 To LastRow

また、

> 未だ4行一組が前後ページを跨いでしまっています

この場合、跨いでいるのは最初の一組目からでしょうか。

3組ぐらい作成してテストしてるのですが、全てのパターンをテストできないので
何組目が駄目で、何行目で駄目になるのか教えてくれないでしょうか。

色で判断しているTest3()も駄目でしょうか。

補足

以下のようにしてください。

For i = 5 To LastRow
Sub Test2()を使って変更しましたがデバッグがかかりました

また、

> 未だ4行一組が前後ページを跨いでしまっています

>この場合、跨いでいるのは最初の一組目からでしょうか。

最初の2ページ目ですでにタイトル行がコピペされていないので正しくは何組目から変動してまうので回答不明です
また相当なページ数でも発生しております

3組ぐらい作成してテストしてるのですが、全てのパターンをテストできないので
何組目が駄目で、何行目で駄目になるのか教えてくれないでしょうか。
149行目で駄目になっています
445行目
741行目
1185行目
など2ページ目から誤作動していますので以降のページはほとんどの頁(全1338頁分)が駄目になってしまっています

>色で判断しているTest3()も駄目でしょうか。
駄目でした

回答No.5

kkkkkm

回答No.4の追加です。

「生」が128行目にあったときにそのままでなく4行上に改ページが必要な場合は

If .Cells(i, "A").Value = "生" And i Mod mRow > 0 And i Mod mRow < 4 Then

を

If .Cells(i, "A").Value = "生" And i Mod mRow >= 0 And i Mod mRow < 4 Then

にしてください。

また、4行一組だけにセルに色がついている場合は以下の方法でもいけると思います。

4行一組の最後の行が128行目にあったときにそのままでなく4行一組の上に改ページが入ります。

Sub Test3()
Dim i As Long, j As Long: j = 0
Dim LastRow As Long, mRow As Long

Application.ScreenUpdating = False

With Sheets("Sheet1")
.ResetAllPageBreaks
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
mRow = 148 + j
If .Cells(i, "A").DisplayFormat.Interior.ColorIndex <> xlNone And _
.Cells(i - 1, "A").DisplayFormat.Interior.ColorIndex = xlNone And _
(mRow - i >= 0 And mRow - i < 4) Then
DoEvents
.Rows(i).PageBreak = xlPageBreakManual
j = i - 1
i = i + 4
ElseIf i Mod mRow = 0 Then
DoEvents
.Rows(i + 1).PageBreak = xlPageBreakManual
j = i
End If
Next
Application.ScreenUpdating = True
.PageSetup.Zoom = 55
End With

End Sub

補足

Sub Test2()の差し替え分と
Sub Test3()を実行したところ
同じエラーで
ある程度の時間が経過したのち実行時エラー1004
Rangeクラスのpage Breakプロパティを設定出来ません。
.Rows(i + 1).PageBreak = xlPageBreakManualのところで停止します
マクロを実行したら、すぐに出るのではなく進捗後に出ます
いったんマクロを終了して印刷プレビューを見ても動作完了していませんでした
55％が100％に変わってしまい何故かこちらでは戻らないようです。最後のほうのコード記述で55%に戻すコードがありますが、マクロ実行中に100％では無く55％で進んでいかないと誤作動するきっかけになってしまうのでしょうか？

回答No.4

kkkkkm

> この4行一組の間にはセルに色が入っていない本文が一行から時には数千行程度に多種多様あります

すみません、4行1組が延々続くデータだと勘違いしてました。

4行一組
本文行数不定
4行一組
本文行数不定
・
・
となっていて4行一組がページをまたがないという事ですね。

T1
T2
T3
T4(生)
本文
T1
T2
改ページ
T3
T4(生)
本文

となった場合

T1
T2
T3
T4(生)
本文
改ページ
T1
T2
T3
T4(生)
本文

にするということと考えて以下のコードにしました。

> 一番下の行が「生」という一文字

なので「生」が見つかった行を含め上4行が一組と考えました。

> RangeクラスのPage Breakプロパティを設定できません

かなりループするとPage Breakでエラーになるという事なので
参考にしたサイト
https://happy-tenshoku.com/post-2546/
https://tibirobo.jpn.org/?p=1795
こちらに解決したQ&Aがありました。
https://okwave.jp/qa/q7851961.html
上記ではApplication.ScreenUpdating = False
では解決しなかったということでしたので
DoEvents
を入れてみました。

Sub Test2()
Dim i As Long, j As Long: j = 0
Dim LastRow As Long, mRow As Long

Application.ScreenUpdating = False

With Sheets("Sheet1")
.ResetAllPageBreaks
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
mRow = 148 + j
If .Cells(i, "A").Value = "生" And i Mod mRow > 0 And i Mod mRow < 4 Then
DoEvents
.Rows(i - 3).PageBreak = xlPageBreakManual
j = i - 4
ElseIf i Mod mRow = 0 And _
WorksheetFunction.CountIf(.Range(.Cells(mRow, "A"), .Cells(mRow + 3, "A")), "生") < 1 Then
DoEvents
.Rows(i + 1).PageBreak = xlPageBreakManual
j = i
End If
Next
Application.ScreenUpdating = True
.PageSetup.Zoom = 55
End With

End Sub

補足

未だ4行一組が前後ページを跨いでしまっています
前のページに{4行、3行、2行、1行}のみ残ってしまった場合は強制的に次のページに4行一組が連続するように先頭行にスライドして行ってください
--------------
T1
T2
T3
T4(生)
本文
T1
T2
------------------
改ページ
T3
T4(生)
本文

となった場合

T1
T2
T3
T4(生)
本文
---------
改ページ
T1
T2
T3
T4(生)
本文

あと⑥ですが
-----------
T1
T2
T3
T4(生)
本文
本文
本文
本文
---------
改ページ
前のページからの続きの本文のTが無いので
本文
本文
の場合は遡って前のページにある最も下にある4行一組と同じものを次ページの先頭行にコピペしていってください
------------
T1　(前頁のコピペ)
T2　(前頁のコピペ)
T3　(前頁のコピペ)
T4(生)　(前頁のコピペ)
本文
本文
----------------
の繰り返しになります

回答No.3

kkkkkm

> やってみましたが再度100％に戻ってしまいました

こちらだと55%のままなのですが・・・

以下を実行すると55%にセットした後、即プレビューが表示されますが、その場合55%になってますでしょうか。

Sub TestPageSetup()
With Sheets("Sheet1")
.PageSetup.Zoom = 55
.PrintPreview
End With
End Sub

> 「1998」を変更して与えてあげる数値がわかりません

9.75X148なので1443にしてみてください。

補足

何故戻らなかったは不明ですが
Sub TestPageSetup()のマクロで55%に戻りました
レイアウトは現状維持できました
この4行一組は前後のページにバラバラに跨らないようにいつもセットでくっ付けておかなければなりません
この4行一組の間にはセルに色が入っていない本文が一行から時には数千行程度に多種多様あります
⑥は実際図が見えないと言葉では非常に説明しづらく、このOKWAVEはPDFのファイルは載せられるのですか？
図だと仰せの通り小さくてぼやけてしまいます

あとデバックがかかったので載せます
実行時エラー’1004’
RangeクラスのPage Breakプロパティを設定できません
'Rows(i+144).page Break=xlpage Break manual
おそらく希望動作する双方の見解が一致していないのでしょう。つたない質問でどうもすいません。
エクセルのファイルかPDFのファイルを送れる方法があればいいと思います

回答No.2

kkkkkm

> マクロを実行すると100％に戻ってしまう

最後の方の

Next
End With

の所を

Next
.PageSetup.Zoom = 55
End With

に変更してみてください。

補足

やってみましたが再度100％に戻ってしまいました

次にここのところで1998はエクセルの既定の行の高さ13.5ポイントの148行分としていますので、実際のポイントは9.75Ｐ(13ピクセル)と狭まっていますので1998を変更しなければならないのですが「1998」を変更して与えてあげる数値がわかりません
各ページ内には37組ピッタリ入るとはl限りません
⑥の疑問点に入る前に先にこちらをどうなるか見てみたいです。

回答No.1

kkkkkm

> ⑥はページ内にタイトル4行が2種類以上～有る場合は最も下部のタイトル4行ごと次ページの先頭行にも同じものをコピペしていって行ってください

画像が大きくてぼやけて見えないのでこれが分からないのですが
それ以外は、4行ごとを1組で最大148行(37組)が1ページに収まる状態で、行の高さが高くなる行もあり37組入りきらないページの場合入りきらない組は次のページに追いやるという事だと思いました。

> 基準148行から1行～4行分少ないページも出来る

という事なので、1組以上追いやる状況は無いと考えて、⑥が分からないので入りきらない組を追いやるだけのコードです。

1998はエクセルの既定の行の高さ13.5ポイントの148行分としていますので、実際のポイントに合わせてください。
Sheet1は実際のシート名にしてください。

ただ、19万行もあるととてつもなく時間がかかると思います。

Sub Test()
Dim i As Long
Dim LastRow As Long

Application.ScreenUpdating = False

With Sheets("Sheet1")
.ResetAllPageBreaks
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If .Range(i & ":" & i + 147).Height <= 1998 Then
.Rows(i + 148).PageBreak = xlPageBreakManual
i = i + 147
Else
.Rows(i + 144).PageBreak = xlPageBreakManual
i = i + 143
End If
Next
End With

Application.ScreenUpdating = True

End Sub

補足

まず一つづつ解決していきたいのですが印刷時のページ設定で拡大縮小印刷で55％に縮小していますが、マクロを実行すると100％に戻ってしまうので各ページあたりA列～D列の4列入らなければならないところA列とB列の2列だけの表示になってしまいレイアウトが崩れてしまうのでマクロ実行中は縮小率55％のままで終了後も保持してほしいです。マクロ終了後に戻してもダメなようです。それからまた改めてお互いの疑問点に追及していければ有難いです。