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

質問

①改ページプレビューを見ていくと最終ページまで各ページ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.17

kkkkkm

あと

別に質問としてあげている画像では7840行が148行目になっていますが、1行目から148を繰り返すと144行目になると思います。
始まりが違うのではないですか。

お礼

コピーしたセルの挿入で下方向にシフトで
先頭ページにタイトルを付けるマクロの自動記録をやってみてタイトル行一組1～2ページ分ですが参考になりますでしょうか
あと申し遅れましたがセルの結合があると全くコードが変わってしまうのですか？
A1とB1
C1とD1
A2とB2
C2とD2
A3とB3
C3とD3
タイトル4行目に「生」の文字が入りセルの結合はないです
Sub Macro1()
' Macro1 Macro
Range("A1:D4").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=108
Range("A149").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=165
Range("A297").Select
Selection.Insert Shift:=xlDown
End Sub

補足

それは適当に特に計算しないで図案がよかったので載せました
図のみが再投稿できないので別に載せた次第です
今まで通りでそちらは無視してください

回答No.16

kkkkkm

> ページを跨がない件は正常に動作していません

回答No.11で添付した画像の様にはならないということですよね。
それでしたら先に進んでも仕方がないと思います。

回答No.15

kkkkkm

> 回答No.13+14でも⑥が2022/07/30 17:12の要望でも出来ません

これについては、現状の4行一組(タイトル)がページを跨がない動作が正常になってからやるという事だったと思いますので、手を付けていません。
ページを跨がない件は正常に動作しているのでしょうか。うまくいかなかったという事しか伝わっていません。

⑥の件ですが
> ⑥の質問だった1ページ内の1行目から148行目内にタイトルが一組しか存在しない場合

二組以上あれば転写しなくていいのでしょうか。

単純に

各ページの先頭行にタイトルが無ければ前のページの最終タイトルを先頭行に追加挿入する

と思ってました。いつも先頭行にタイトルがあるとは思えないので、ほとんどの場合追加挿入になるなぁと思ってたのですが・・・。

タイトル4行A
本文
タイトル4行B
本文
改ページ----------------
本文
改ページ----------------
本文
タイトル4行C
本文
改ページ----------------
本文

の場合

タイトル4行A
本文
タイトル4行B
本文
改ページ----------------
タイトル4行B
本文
改ページ----------------
タイトル4行B
本文
タイトル4行C
本文
改ページ----------------
タイトル4行C
本文

タイトルがないページには前ページの最終タイトルが追加挿入されるというイメージです。

補足

ページを跨がない件は正常に動作していません
二組以上でも転写してください
タイトルがないページには前ページの最終タイトルが追加挿入されるというイメージです。それでOKです

回答No.14

kkkkkm

回答No.13の

j = i + (mRow - i)
は
j = mRow
でした。

時間が無くて焦ってました。

補足

誤）どのページも148行目が本文で丁度終わればいいのです
正）どのページも145行目～148行目が本文又はデータなしで丁度終わればいいのです

回答No.13+14でも⑥が2022/07/30 17:12の要望でも出来ません
当方の質問内容はどこか矛盾していないで大丈夫でしょうか？

回答No.13

kkkkkm

回答No.11の差し替えです。
こちらで試してみてください。

Sub Test3_3()
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 = 5 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
.Range(.Rows(i), .Rows(mRow)).Insert
j = i + (mRow - i)
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

回答No.12

kkkkkm

No.11は一部間違ってますので実行しないでください。

回答No.11

kkkkkm

行を挿入するのですね

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

と書いてありましたし、改ページすれば印刷時には1ページ148行になるので改ページだけでいいと思ってました。

セルの色付きで判断する方です。(「生」で判断すると上に戻ったりしてややこしくなるのでこちらでお願いします)
7844行と7992行の下に改ページが入っています。
ただし、先にも回答しましたが改ページの制限でエラーになるのは避けられないと思います。

Sub Test3_2()
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
.Range(.Rows(i), .Rows(mRow)).Insert
j = i
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

補足

段々と解明されてきたかも知れませんが
あともう一点お忘れかと思いますが、⑥の質問だった1ページ内の1行目から148行目内にタイトルが一組しか存在しない場合で本文が何ページにもわたって続く場合はその同じタイトルを次ページ目の先頭にも転写して同一タイトル上の本文が終了するまで繰り返し転写していってください
なのでどのページも148行目が本文で丁度終わればいいのです
ブックの分割はマクロの動作が正しくなったら後でやります。

回答No.10

kkkkkm

> 結局分割してもマクロは希望通りには動作OKにはなりませんでした

そうでしたか、残念です。
2万行ほどでテストしてるのと私が何か勘違いして実際のデータと違う状態でテストしているのかもしれません。

画像はテストの一部分です。7841の上に改ページがあるので本来7989の上で改ページですが4行一組が7987から始まっているのでそこに改ページが入っています。
途中でも改ページを跨がないように調整している所があるので148の倍数にはなっていません。

補足

1ページごとの148行は不動です。減らさないでください
4行一組のタイトルデータだけが次ページに移行します

回答No.9

kkkkkm

ページの%設定の件ですが、エラーで止まると最後の設定が実行されませんから55％にならないのだと思います。
念のために最初にも入れておいてもいいかもしれません。

.ResetAllPageBreaks
のところを
.ResetAllPageBreaks
.PageSetup.Zoom = 55

また、4行一組が前後ページを跨ぐ件についてはエラーが出なくなってから考えることにしてください。

回答No.8

kkkkkm

仕様と制限を見ると

https://support.microsoft.com/ja-jp/office/excel-%E3%81%AE%E4%BB%95%E6%A7%98%E3%81%A8%E5%88%B6%E9%99%90-1672b34d-7043-467e-8e27-269d656771c3

改ページ

水平方向および垂直方向に 1,026

となっていました。恥ずかしながら、このような制限があるとは知りませんでした。

> すぐに出るのではなく進捗後に出ます

ということですので、19万行以上1278ページなので制限を超えたところでエラーになっているのではないでしょうか。

ブックを分割してみてはいかがでしょう。

お礼

結局分割してもマクロは希望通りには動作OKにはなりませんでした
質問内容の不手際からご迷惑をお掛けしております
特にブックの分割は考えておりません
ここは解決としないでこのままの状態にしておきますので
気が向いた時にでも回答されると有難いです
すでに手作業でも並行して開始しております
現在30ページまで終わりましたが何日いや何十日掛かるか分かりませんが頑張ります
ありがとうございました