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

質問

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

HohoPapa

残っている課題は

(01)
実行時エラー’1004’Range クラスの Page
Break プロパティを設定できません。
→ShPut.Rows(r).PageBreak = xlPageBreakManual-----ここで黄色の反転表示でSTOPします

(02)
tgRng.Borders.ThemeColor = 1のところです
空白行があるページの罫線が見えなくなっていませんでした

(03)
全行全列の文字列が縮小表示になっていませんでした

と理解しました。

(01)の課題
改ページをセットできる数に1026があるものの
縦方向の改ページもカウントされることから
これを考慮したつもりでしたが
実際は更に少ないようです。

そこで、

　'改ページ設定 最大1024ページ
　For r = 1 To CntPut
　　If ((r Mod 148 = 1) And (r > 1)) Then
　　 PageCnt = PageCnt + 1
　　 If PageCnt > 1024 Then Exit For
　　　ShPut.Rows(r).PageBreak = xlPageBreakManual
　　End If
　Next r

を

'改ページ設定 最大1020ページ
For r = 1 To CntPut
If ((r Mod 148 = 1) And (r > 1)) Then
PageCnt = PageCnt + 1
If PageCnt > 1020 Then Exit For
ShPut.Rows(r).PageBreak = xlPageBreakManual
End If
Next r
としてみてください。

(02)の課題
よくわからないです。
エラーメッセージの詳細とOfficeのバージョンを教えてください。

(03)
これもよくわからないです。

Sub FontSet()
　～～～　　
　With ShPut.Cells
　　.ShrinkToFit = True　　<===ここ
　End With
　～～～　　
End Sub

ここで
>セル全部内は全体を縮小して表示
を行っています。

コードやっていることと期待することがかみ合っていませんか？

お礼

(02)の課題
Officeのバージョンは365の最新アップデート完了済みです

補足

(1)　動作OKです
　　止まらなかったです
(2)　実行時エラー'91'
　　オブジェクト 変数 またはWith ブロック変数が
　　設定されていませんと出ました
(3)　動作OKです
　　全体が縮小されていました
それで(2)がデバッグが掛かるので
tgRng.Borders.ThemeColor = 1のところで
罫線色が白色に設定されないので空白行でも黒色の可視セルなのでしょうか？

回答No.26

HohoPapa

以下、前項からの続き

Sub PrintDef(LastRow As Long)

　Application.PrintCommunication = False
　With ShPut.PageSetup
　　.PrintTitleRows = ""
　　.PrintTitleColumns = ""
　End With
　Application.PrintCommunication = True
　ShPut.PageSetup.PrintArea = "$A$1:$D$" & LastRow
　Application.PrintCommunication = False

　With ShPut.PageSetup
　　.LeftHeader = ""
　　.CenterHeader = ""
　　.RightHeader = ""
　　.LeftFooter = ""
　　.CenterFooter = "- &P -"
　　.RightFooter = ""
　　.LeftMargin = Application.InchesToPoints(0.31496062992126)
　　.RightMargin = Application.InchesToPoints(0.31496062992126)
　　.TopMargin = Application.InchesToPoints(0.393700787401575)
　　.BottomMargin = Application.InchesToPoints(0.393700787401575)
　　.HeaderMargin = Application.InchesToPoints(0.31496062992126)
　　.FooterMargin = Application.InchesToPoints(0.196850393700787)
　　.PrintHeadings = False
　　.PrintGridlines = False
　　.PrintComments = xlPrintNoComments
　　.PrintQuality = 600
　　.CenterHorizontally = True
　　.CenterVertically = False
　　.Orientation = xlPortrait
　　.Draft = False
　　.PaperSize = xlPaperA4
　　.FirstPageNumber = xlAutomatic
　　.Order = xlDownThenOver
　　.BlackAndWhite = False
　　.Zoom = 55
　　.PrintErrors = xlPrintErrorsDisplayed
　　.OddAndEvenPagesHeaderFooter = False
　　.DifferentFirstPageHeaderFooter = False
　　.ScaleWithDocHeaderFooter = True
　　.AlignMarginsHeaderFooter = True
　　.EvenPage.LeftHeader.Text = ""
　　.EvenPage.CenterHeader.Text = ""
　　.EvenPage.RightHeader.Text = ""
　　.EvenPage.LeftFooter.Text = ""
　　.EvenPage.CenterFooter.Text = ""
　　.EvenPage.RightFooter.Text = ""
　　.FirstPage.LeftHeader.Text = ""
　　.FirstPage.CenterHeader.Text = ""
　　.FirstPage.RightHeader.Text = ""
　　.FirstPage.LeftFooter.Text = ""
　　.FirstPage.CenterFooter.Text = ""
　　.FirstPage.RightFooter.Text = ""
　End With
　Application.PrintCommunication = True

End Sub

Sub FontSet()
　With ShPut.Cells.Font
　　.Name = "ＭＳ Ｐゴシック"
　　.Size = 9
　　.Strikethrough = False
　　.Superscript = False
　　.Subscript = False
　　.OutlineFont = False
　　.Shadow = False
　　.Underline = xlUnderlineStyleNone
　　.ThemeColor = xlThemeColorLight1
　　.TintAndShade = 0
　　.ThemeFont = xlThemeFontMinor
　End With

　With ShPut.Cells
　　.ShrinkToFit = True
　End With

　ShPut.Columns("A:D").ColumnWidth = 30

End Sub

Sub LinesSet(LastRow As Long)

　Dim r As Long
　Dim tgRng As Range

　'範囲全体に罫線を引く
　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
　　　Set tgRng = Range(ShPut.Cells(r - 3, 1), ShPut.Cells(r, 4))
　　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
　　　Set tgRng = Range(ShPut.Cells(r - 2, 1), ShPut.Cells(r, 4))
　　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
　　　Set tgRng = Range(ShPut.Cells(r - 1, 1), ShPut.Cells(r, 4))
　　ElseIf ( _
　　　(ShPut.Cells(r, 1) = "") And _
　　　(ShPut.Cells(r, 2) = "") And _
　　　(ShPut.Cells(r, 3) = "") And _
　　　(ShPut.Cells(r, 4) = "")) Then
　　　Set tgRng = Range(ShPut.Cells(r, 1), ShPut.Cells(r, 4))
　　End If
　　tgRng.Borders.ThemeColor = 1

　　r = r + 148

　Loop

End Sub

補足

お待ちしておりました
ありがとうございます
超高速になりました
最初に
Sheet1→添付先
ShPut.Columns("A:D").ColumnWidth = 30→40です
ここはこちらで変更しちゃっても何ら問題無いでしょうか？

(01)Sheet3の前処理（クリアーなど）が面倒なので
　Sheet3を削除し、aratanaSheet3を用意するように変更→OK
ここから先がデバッグが掛かり確認出来ませんでした
実行時エラー’1004’Range クラスの Page
Break プロパティを設定できません。
→ShPut.Rows(r).PageBreak = xlPageBreakManual-----ここで黄色の反転表示でSTOPします
(02)改ページの設定は最大値までしか行わない→不明
(03)印刷用の設定を追加→不明
(04)文字サイズ、列幅の設定を追加→不明
(05)罫線を引くように。→不明

回答No.25

HohoPapa

以下でいかがでしょうか。

(01)Sheet3の前処理（クリアーなど）が面倒なので
　Sheet3を削除し、aratanaSheet3を用意するように変更
(02)改ページの設定は最大値までしか行わない
(03)印刷用の設定を追加
(04)文字サイズ、列幅の設定を追加
(05)罫線を引くように。

Option Explicit

　Dim ShGet As Worksheet
　Dim ShPut As Worksheet

Sub sample1()

　Dim CntGet As Long
　Dim CntPut As Long
　Dim LastRow As Long
　Dim r As Long
　Dim GetRange As Range
　Dim PutRange As Range
　Dim LastTitleRow As Long
　Dim RngTitle As Range
　Dim PageCnt As Long
　Dim R1 As Long
　Dim R2 As Long
　Dim R3 As Long
　Dim R4 As Long

　Set ShGet = ThisWorkbook.Sheets("Sheet1")
　Application.DisplayAlerts = False
　On Error Resume Next
　Sheets("Sheet3").Delete
　On Error GoTo 0
　Application.DisplayAlerts = True
　Set ShPut = Sheets.Add(After:=ActiveSheet)
　ShPut.Name = "Sheet3"　'出力先シート名

　PageCnt = 0
　CntPut = 1
　CntGet = 1
　Set RngTitle = _
　　Range(ShGet.Cells(1, 1), ShGet.Cells(4, 4)) '先頭のTitle範囲を記憶
　R1 = ShGet.Cells(Rows.Count, 1).End(xlUp).Row
　R2 = ShGet.Cells(Rows.Count, 2).End(xlUp).Row
　R3 = ShGet.Cells(Rows.Count, 3).End(xlUp).Row
　R4 = ShGet.Cells(Rows.Count, 4).End(xlUp).Row
　LastRow = WorksheetFunction.Max(R1, R2, R3, R4)

　Do

　　If CntGet > LastRow Then Exit Do

　　'タイトルか？
　　If ((ShGet.Cells(CntGet + 0, 1).Value <> "生") And _
　　　　(ShGet.Cells(CntGet + 1, 1).Value <> "生") And _
　　　　(ShGet.Cells(CntGet + 2, 1).Value <> "生") And _
　　　　(ShGet.Cells(CntGet + 3, 1).Value = "生")) Then

　　　If CntPut Mod 148 = 0 Then
　　　　CntPut = CntPut + 1
　　　ElseIf CntPut Mod 148 = 147 Then
　　　　CntPut = CntPut + 2
　　　ElseIf CntPut Mod 148 = 146 Then
　　　　CntPut = CntPut + 3
　　　ElseIf CntPut Mod 148 = 145 Then
　　　　CntPut = CntPut + 4
　　　End If
　　　Set GetRange = Range(ShGet.Cells(CntGet, 1), ShGet.Cells(CntGet + 3, 4))
　　　Set PutRange = Range(ShPut.Cells(CntPut, 1), ShPut.Cells(CntPut + 3, 4))
　　　RngTitle.Copy PutRange
　　　PutRange.Value = GetRange.Value
　　　LastTitleRow = CntGet '最後に出力したタイトル行の複写元開始行を記憶

　　　CntGet = CntGet + 4
　　　CntPut = CntPut + 4

　　Else

　　　If CntPut Mod 148 = 1 Then
　　　　CntPut = CntPut + 4
　　　　Set GetRange = _
　　　　　　Range(ShGet.Cells(LastTitleRow, 1), ShGet.Cells(LastTitleRow + 3, 4))
　　　　Set PutRange = _
　　　　　　Range(ShPut.Cells(CntPut - 4, 1), ShPut.Cells(CntPut - 1, 4))
　　　　RngTitle.Copy PutRange 'Titleの色を含んで複写
　　　　PutRange.Value = GetRange.Value　'値複写
　　　End If

　　　Set GetRange = Range(ShGet.Cells(CntGet, 1), ShGet.Cells(CntGet, 4))
　　　Set PutRange = Range(ShPut.Cells(CntPut, 1), ShPut.Cells(CntPut, 4))
　　　PutRange.Value = GetRange.Value
　　　CntGet = CntGet + 1
　　　CntPut = CntPut + 1

　　End If

　Loop
　CntPut = CntPut - 1

　'行高を設定
　ShPut.Range(Rows(1), Rows(CntPut)).RowHeight = 9.75

　'改ページ設定 最大1024ページ
　For r = 1 To CntPut
　　If ((r Mod 148 = 1) And (r > 1)) Then
　　 PageCnt = PageCnt + 1
　　 If PageCnt > 1024 Then Exit For
　　　ShPut.Rows(r).PageBreak = xlPageBreakManual
　　End If
　Next r

　'印刷設定
　PrintDef CntPut

　'文字サイズ、列幅、セル表示設定
　FontSet

　'罫線設定
　LinesSet CntPut

　MsgBox "セット終了"

End Sub

次へ続く

補足

一生懸命作成していただいたので、二度目の検証とともに事象を再検査しました
最初のデバッグのところの記述を削除してみました
ShPut.Rows(r).PageBreak = xlPageBreakManualのところです再動作しますが、その後2番目のデバッグが掛かりました
tgRng.Borders.ThemeColor = 1のところです
空白行があるページの罫線が見えなくなっていませんでした
最下行のデータの欠落は修正されていました
全行全列の文字列が縮小表示になっていませんでした
マクロが最後まで完全に終了しないと、どうなるのか判らないようです

回答No.24

HohoPapa

罫線やフォントなどの対応を行ったコードをポストしたいものの
本業に追われ数日時間がとれません。
気長に待ってください。
週末には時間が取れると思います。

なお、罫線を仕組むとやたらコードが長くなりそうです。
１段落したら、
先にちょっと触れましたが、
印刷用のシートを用意し、
そこにページ単位にデータを複写し印刷する仕様にしたほうがいいと思います。

また、データも１０数万行ではなく、数万行程度で分割したほうが
無難と思います。

お礼

>データも１０数万行ではなく、数万行程度で分割
これに関しては全件一斉に検索、書き込み・追加・修正等の追加変更があるので分割が駄目というか面倒な理由なんです
ファイルを分ければ分けるほど見直しが大変です
出来れば一気通貫のほうが何かと便利なわけです

補足

お忙しいところ大変ありがとうございます
本業とは「エクセルの開発に携わっているのかな」と想像してしまいます

罫線についてなんですが細かく指定すると複雑になってしまうので、これはSheet1→添付先のシートに転写する際に表の体裁のレイアウトが変わっているので印刷設定で枠線にチェックを入れた物のほうが楽で別に問題ないのですが見た目上データが無いのに枠線だけあっても違和感があるので希望を含めるとページ最下段のA列～D列145行目から148行目が空白セルの場合のみ左右・中・下線の色を白色にすれば枠線にチェックが入っても可視セルにはならないのでその方法でお願い致します

このマクロにこだわるかと申しますと毎年約1500名程度データが追加されていきます(仕事とかで強制的では無いく趣味です）
このマクロが実現出来ればいつでも素早く改訂版を出せます
もうすでに最初のマクロで完成はしていますが何か高速版を作成されているとのことなので楽しみです
もう手作業は止めました
引き続きご検討頂ければ幸甚です

回答No.23

HohoPapa

>ただし最終組のタイトル行の明細が一行あったのですが後で気が付いたのですが落ちていました
これは、最終行のＡ列の値が空欄ではないでしょうか？

最終行がどこなのかは、
シートの最下行（1048576行目）のA列から上方向に遡り
最初に値の埋まったセルという求め方をしています。

罫線を引くマクロを提示してもらいましたが
尻切れと思います。
改めてポストしてみてください。

また、提示されたマクロで示しているには
1ブロックの範囲を選んで実行する場合のコードですね？
それとも1行目から末尾行のＤ列を選択していますか？

更に、1ブロックの範囲を選んで実行する場合、
中には、末尾に1行から4行の空白の行があるわけですが
この行も罫線を引く対象ですか？
それとも非対象（罫線を引かない）ですか？

お礼

'' Macro1 Macro
' Range("A191513:D191659").Select
「'」はマクロの自動記録特有の変なスペースを詰めた結果で「']は無視してください

補足

編集元シートにB列の最終行に明細行(一名)がいました
これはA列の最も最終行のタイトル「生」の更に下行にB列～D列に最後の明細行あると途切れる可能性があります

尻切れすいませんでした
たまたま4行×4列分に絞ってみた範囲(表)を選んで実行する場合のコードでした
再返信に図が載せられないので申し訳ないです
下は実際のページです
マクロの自動記録は1295ページ内のA列～D列のいずれかに最後の4行(145行目～148行目)に空白行が発生している場合にしてみました(絶対参照)
Sub Macro1()
'' Macro1 Macro
' Range("A191513:D191659").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Range("A191656:D191659").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
1ブロックの範囲を選んで実行する場合、
中には、末尾に1行から4行の空白の行があるわけですが
この行も罫線を引く対象ですか？
それとも非対象（罫線を引かない）ですか？
引かないです
セル枠の選択範囲の罫線を白色にして見えなくしてください(ただし一番上の罫線は残します）田の字でいうと
一番上の「一」だけ残す感じです

回答No.22

HohoPapa

10数万行のデータで検証してみたところ、
（知らなかったんですが）
１シートに設定できる改行の数は1026個が限界値らしく、
これを超えるところでエラーになっています。
この対応は後ほど。※

>マクロの動作は早くて30分程度です。
>ずっと数時間程度待ってれば、いずれはマクロの動作が完了するのでしょうか？
安易なコードの部分があり、甚だしく性能の悪いコードでした。
具体的には、
1行ごとに行高を設定していましたので、
これを1行目から印刷対象の最終行までをまとめて行うようにし
後ほどコードをポストします。※
長くても数分で済む処理になるはずです。

>印刷設定は位置左右0.8㎝、
>天地1㎝　
>ヘッダー0.8㎝、フッター0.5㎝、ページ中央水平にチェック、
>フッター編集　- &[ページ番号] - 表示例) -1575 -
>エクセル固有の枠線にチェック(罫線の指定はないです)
>編集元はすべて文字の大きさが9ポイント、
>セル全部内は全体を縮小して表示、セルの高さ9.75ポイント、
>A列～D列のセル幅は40.00(325ピクセル)
>これをマクロに組み込んで頂ければなお有難いです

コード化の作業が単純ではないので
以下の要領でマクロを記録しポストしてください。

マクロの記録を開始
ページレイアウトのページ設定を開く
期待する設定内容であることを確認しＯＫボタンを押下
マクロの記録を終了

ポストされた内容をもとに印刷設定部分を組み込み
列幅変更を行い
※部分を対応して、コードをポストします。

印刷設定が期待通りで、行高が適切なら
改ページの設定を明示的に行わずとも
148行ごとに改ページしてくれると思います。

もし、途中でズレが起きるようなら
印刷専用のシートを設け、
148行単位で、シートに複写、印刷する動作を
ページ数繰り返す対応にならざるを得ないと思います。

お礼

印刷設定
Sub Macro1()'
' Macro1 Macro'
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "- &P -"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.31496062992126)
.RightMargin = Application.InchesToPoints(0.31496062992126)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.196850393700787)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 55
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
End Sub

罫線について
Sub Macro2()
' Macro2 Macro
Range("A1:D6").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
Range("B1:C6").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Border

補足

印刷設定は後で戻せば問題なかったです
改行は1026まで行っていないようで
最後の1375頁まで刷れていました
ただし最終組のタイトル行の明細が一行あったのですが後で気が付いたのですが落ちていました
これは不具合なのか改行1026を偶然超えての企画なのか定かではありません
あと枠線→罫線に指定して田んぼの田の字で周り(口)は普通の罫線で中の「十」は点線に変更してB列とC列の境界線は
普通の実線が希望でページの１～4行の空白が出たページは最後の下線は実線で残りは罫線を白色に変更して不可視セルにしていただければ尚可です

回答No.21

HohoPapa

以下のコードでいかがでしょうか。

・編集元シート：Sheet1
・出力先シート：Sheet3
・出力先シートはマクロの先頭で全数クリアーしています。
・罫線を考慮していません。
　　必要なら、どのように罫線が引かれているかを
　　説明してください。マクロで罫線を引きます。
・148行ごとに改ページを設定しています。

Option Explicit

Sub sample1()

Dim CntGet As Long
Dim CntPut As Long
Dim LastRow As Long
Dim ShGet As Worksheet
Dim ShPut As Worksheet
Dim r As Long
Dim GetRange As Range
Dim PutRange As Range
Dim LastTitleRow As Long
Dim RngTitle As Range

CntPut = 1
CntGet = 1
Set ShGet = ThisWorkbook.Sheets("Sheet1")
Set ShPut = ThisWorkbook.Sheets("Sheet3")
ShPut.Cells.ClearContents '出力先をクリアー
ShPut.Cells.MergeCells = False
With ShPut.Cells.Interior '出力先の配色をクリアー
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Set RngTitle = _
Range(ShGet.Cells(1, 1), ShGet.Cells(4, 4)) '先頭のTitle範囲を記憶
LastRow = ShGet.Cells(Rows.Count, 1).End(xlUp).Row '最終行番号を取得

Do

If CntGet > LastRow Then Exit Do

'タイトルか？
If ((ShGet.Cells(CntGet + 0, 1).Value <> "生") And _
(ShGet.Cells(CntGet + 1, 1).Value <> "生") And _
(ShGet.Cells(CntGet + 2, 1).Value <> "生") And _
(ShGet.Cells(CntGet + 3, 1).Value = "生")) Then

If CntPut Mod 148 = 0 Then
CntPut = CntPut + 1
ElseIf CntPut Mod 148 = 147 Then
CntPut = CntPut + 2
ElseIf CntPut Mod 148 = 146 Then
CntPut = CntPut + 3
ElseIf CntPut Mod 148 = 145 Then
CntPut = CntPut + 4
End If
Set GetRange = Range(ShGet.Cells(CntGet, 1), ShGet.Cells(CntGet + 3, 4))
Set PutRange = Range(ShPut.Cells(CntPut, 1), ShPut.Cells(CntPut + 3, 4))
RngTitle.Copy PutRange
PutRange.Value = GetRange.Value
LastTitleRow = CntGet '最後に出力したタイトル行の複写元開始行を記憶

CntGet = CntGet + 4
CntPut = CntPut + 4

Else

If CntPut Mod 148 = 1 Then
CntPut = CntPut + 4
Set GetRange = _
Range(ShGet.Cells(LastTitleRow, 1), ShGet.Cells(LastTitleRow + 3, 4))
Set PutRange = _
Range(ShPut.Cells(CntPut - 4, 1), ShPut.Cells(CntPut - 1, 4))
RngTitle.Copy PutRange 'Titleの色を含んで複写
PutRange.Value = GetRange.Value '値複写
End If

Set GetRange = Range(ShGet.Cells(CntGet, 1), ShGet.Cells(CntGet, 4))
Set PutRange = Range(ShPut.Cells(CntPut, 1), ShPut.Cells(CntPut, 4))
PutRange.Value = GetRange.Value
CntGet = CntGet + 1
CntPut = CntPut + 1

End If

Loop

'行高、改ページを設定
For r = 1 To CntPut
ShPut.Rows(r).RowHeight = 13
If ((r Mod 148 = 1) And (r > 1)) Then
ShPut.Rows(r).PageBreak = xlPageBreakManual
End If
Next r

End Sub

お礼

縮小拡大印刷は、55％に設定でした

補足

検証を2通りやっていましたもので遅くなりすいませんでした
結論から一発で動作完全にOKでした
まさしくこの通りでバッチリです
すごいです、難しいコードであんまり作成も速くて驚きました
kkkkkm様もすごいのですが
上には上がいてプロ中のプロがその道にはいらっしゃるものだとつくづく痛感致しました
途中手作業と照らし合わせて見たところ当方もコピペ間違いもなくて行数・ページ数の箇所がマクロと完全に一致しました
ご存じのようにオーバーフロー'1004”(1375頁止まりでした)
そこで2通り検証したというのは、”添付先”のシートからSheet3に転写する際にSheet3にページ設定を行わないでそのまま転写するとレイアウトが崩れてのち手作業しますがマクロの動作は早くて30分程度です。ところがあらかじめSheet3にも”添付先”のシートと同じように印刷設定してからマクロを実行すると今度はとてつもなく時間が掛かってしまいます
応答不能に陥り真っ白な画面になってしまいます
ESCキーも効きません。タスクマネージャーで強制終了しかありませんでした
そこでSheet3にも、すべての印刷設定をマクロに組み込めれば当方はぶっちゃけマクロを実行するだけです

印刷設定は位置左右0.8㎝、天地1㎝　ヘッダー0.8㎝、フッター0.5㎝、ページ中央水平にチェック、フッター編集　- &[ページ番号] - 表示例) -1575 -
エクセル固有の枠線にチェック(罫線の指定はないです)
編集元はすべて文字の大きさが9ポイント、セル全部内は全体を縮小して表示、セルの高さ9.75ポイント、A列～D列のセル幅は40.00(325ピクセル)
これをマクロに組み込んで頂ければなお有難いです
自分のパソコンは第三世代のcore i7 16Gbのメモリーなのですがそれぐらいでは遅くなっちゃうのでしょうか？
ずっと数時間程度待ってれば、いずれはマクロの動作が完了するのでしょうか？

回答No.20

HohoPapa

望まれている仕様が把握できないので
発言を躊躇し、外野から静観していました。
が、思い切って発言します。

コードを例示するはヤブサカではありませんが、
期待する仕様を正確に把握してからにしようと思います。

以下、私の理解です。
長文となりますが、よかったら確認してください。

01)4行1組をタイトル行と呼ぶ
02)それに続く行を明細行と呼ぶ
03)1つのタイトルとそれに続く明細の１組をブロックと呼ぶ
04)ブロックごとの明細の行数は、最小が1行、最大は数百行になる。
05)行高は、4行1組のタイトル行も、それに続く明細行も
　　例外なく、13ピクセルである。
06)1ページに印刷可能な最大行数は148行である。
07)Sheet1の1行目から印刷する
08)タイトル行がページを跨ぐ場合は
　　その直前（直前ブロックの明細の最終行）まで印刷して
　　改ページする。
　　つまり、ページごとに最大4行分の空白が末尾に発生する場合がある。それを超える空白にはならない。
09)明細行の少ないブロックが連続する場合は、
　　1ページに複数ブロックを印刷する。
10)明細行がページの1行目から開始する場合は、
　　4行、下方向にシフトして、タイトル行を印刷する。
11)タイトル行の4行には、何色かを使っているものと思いますが
　　　どのブロック用のタイトル行の配色は同じである。
12)タイトル行かどうかは、以下の条件で判断できる。
　　"生"の埋まっていない行が3行続き、その直後の行に"生”が埋まっている。

行番号で示すと

行番号
001～004　タイトルA　4行
005～146　明 細 行A　142行　
147～150　タイトルB　4行
151～153　明 細 行B　3行
154～157　タイトルC　4行
158～183　明 細 行C　26行
184～187　タイトルD　4行
188～487　明 細 行D　300行
488～491　タイトルE　4行
492～521　明 細 行E　30行

こんな具合のデータの場合は

1ページ目
　タイトルA(4行)
　明 細 行A(142行) 計146行 2行分空白

2ページ目
　タイトルB(4行)
　明 細 行B(4行)
　タイトルC(4行)
　明 細 行C(26行)
　タイトルD(4行)
　明 細 行D(106行) 計148行

3ページ目
　タイトルD(4行)
　明 細 行D(144行) 計148行

4ページ目
　タイトルD(4行)
　明 細 行D(50行)
　タイトルE(4行)
　明 細 行E(30行)
　・・・
　・・・　　　　　計148

としたい。

そこで、
Sheet1の19万行以上のデータを
以下のように、Sheet2に出力する

◆１ページ
001～004　タイトルA　4行
005～146　明 細 行A　142行　
147～148　空行

◆2ページ
149～152　タイトルB　4行
153～155　明 細 行B　3行
154～159　タイトルC　4行
160～185　明 細 行C　26行
186～189　タイトルD　4行
190～296 明 細 行D　107行

◆3ページ
297～300　タイトルD　4行　
301～444　明 細 行D　144行

◆4ページ
445～448　タイトルD　4行
449～497　明 細 行D　49行
498～501　タイトルE　4行
502～531　明 細 行E　30行

このような処理でいかがでしょうか？

お礼

投稿後に読み直したら敬称略していました
HohoPapa様です
誠に申し訳ございませんでした

補足

kkkkkm様スタンバイで
HohoPapa新規でありがとうございます
Sheet1はすでにデータで利用しています
Sheet2は”添付先”とシート名を変更していますので
Sheet3に出力をお願いします
01)～12)でそれに相違ございません
最初の1000頁ぐらいは
各ブロックごとの明細の行数は数千行に及ぶものもあります
やがて下方の行番号に行くほど明細が少しづ減少して行き、しまいにはA列に無いこともありB・C・D列のいずれかに1明細しかないこともあります(なのでA列～D列の0明細はタイトル4行一組をマクロで削除完了していますので絶対無いです）
一番目最初のタイトル行グループに続く明細は非常に多くて、すでに手作業にて各ページの先頭にコピペが割り振り完了していますので1行目から1490行目で同一組が完了し1491行目から別なタイトル群になっています
このことから各ページの先頭行に、このコピペ作業がコードに組み込まれないとどんどん誤作動していってしまうわけです
現在むきになってkkkkkm様に励まされたので手作業でせっせと頑張って82292行目がタイトル行として557頁までこじつけました(あと800頁で一か月は掛かりそうも無さそう)
かなり高難易度らしく大変ですが決して無理をなさらないでください
あくまでも出来たらお願いしますということで、ここを閲覧されている達人様方に怒られてしまいますから。

回答No.19

kkkkkm

> こちらでは大変重要事項なことです

重要じゃないとは言ってません、どうも前提を読み飛ばして理解するようですね。

> kkkkkmさんが雲をつかむような話になります。ということはここらへんでお開きと致します

正常に動かない環境がこちらに無いのですから、正常に動かない環境で状態を切り分けたテストをした結果がわからなければ「雲をつかむ話」ですよ。

どちらにしても、あと13倍でしたらひと月もすれば完成ですね。頑張ってください。

回答No.18

kkkkkm

> 先頭ページにタイトルを付ける

跨っているのを正常に処理できないのにそこまで考えなくていいと思います。

とりあえず
回答No.11に添付した画像と同じデータを作成し、実行してうまくいかなければ根本的に何か違うということになりますね。

上記が正常にいけば

For i = 5 To LastRow
の
LastRow
を200にして実行、OKなら400にして実行というように範囲を広げて試してみるとかですね。

そちらで、色々試してどのようなデータで処理できなくなるのか見つけないとこちらでは雲をつかむような話になります。

> あと申し遅れましたがセルの結合があると全くコードが変わってしまうので
> すか？

セルに色さえついていれば問題ないと思いますが、結合していないシートを作成して試してみてください。

Test3_3で試してみてください。

Sheet1は実際のシート名に変更してますよね。

補足

そこまで考えなくていいと思います。こちらでは大変重要事項なことです
kkkkkmさんが雲をつかむような話になります。ということはここらへんでお開きと致します
この度は申し訳ありません、大変お疲れさまでした
マクロコード作成中には並行して手作業の方も100頁まで進み、あとこの13倍の労力を必要としますが頑張ることにします