[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA 改ページの印刷範囲を条件で判断する』（いちち）
下記のように入力されたシートがあります。行は可変です。
毎回手作業で印刷範囲を設定し調整が必要な場合は調整してから印刷をしています。
今回マクロにてやりたいことは、この調整して印刷する部分です。
1ページに収まることもあるのでその時は問題ないのですが、何ページにもなった際に、
数字のまとまりが2枚に分かれないように改ページを調整しています。
例えば10行目が1ページの最後になってしまっていたら
9行目を1ページの最後に設定し、
10行目を2ページ目の先頭にする。（必ずページの先頭が数字になる）
数字のまとまりも1行だったり3行だったりとかなりバラバラです。
ただ印刷範囲を設定するだけでよければ下記のようなコードになると思いますが、条件を付ける方法が分かりません。
宜しくお願いします。
A B C D E F 1 7 2 AAAA A A A A 秋 3 BBBB B B B B 秋 4 CCCC C C C C 秋 5 8 6 AAAA A A A A 秋 7 AAAB B B B B 秋 8 1 9 BBBBB C C C C 秋 10 2 11 CCCC C C C C 石 12 5 . . . . . . . . . .
Sub test()
Dim lastrow As Long
With ActiveSheet .ResetAllPageBreaks
lastrow = .Range("F" & Rows.Count).End(xlUp).Row
.PageSetup.PrintArea = "$A$1:$F$" & lastrow .PrintOut copies:=1, collate:=True
End With
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞
Sub test()
Dim lastrow As Long
Dim i As Long
With ActiveSheet
.ResetAllPageBreaks
lastrow = .Range("F" & Rows.Count).End(xlUp).Row
.PageSetup.PrintArea = "$A$1:$F$" & lastrow
For i = 1 To .HPageBreaks.Count
If .HPageBreaks(i).Location.Row Mod 2 = 0 Then
.HPageBreaks.Add before:=.HPageBreaks(i).Location.Offset(-1, 0)
DoEvents
End If
Next i
.PrintOut copies:=1, collate:=True
End With
End Sub
（???） 2019/06/24(月) 10:50
＞必ず2行1セット、という訳ではないようですね？
＞Offsetも、必ず1行ではなく、A列の値を見てカウントしてみてください。
そうなんです。なのでアドバイス通りにA列で判断しようかと思いましたが、数字も枝番等がつく場合も
あるので、数字をB列に変え、A列が空欄かそれ以外かで判断しようと思います。
A B C D E F 1 7 2 AAAA A A A A 秋 3 BBBB B B B B 秋 4 CCCC C C C C 秋 5 8 6 AAAA A A A A 秋 7 AAAB B B B B 秋 8 1 9 BBBBB C C C C 秋
＞If .HPageBreaks(i).Location.Row Mod 2 = 0 Then
これをIf .HPageBreaks(i).Location.Range("A" & i) <> "" Then
に変えてみましたが(このコードで合ってるか自信ありませんが・・)
そのあとのOffsetをどのようにしたらA列をみて判断できるのでしょうか？
（いちち） 2019/06/24(月) 14:09
A列が空欄かそれ以外かで判断しようと思います。 参考に
For i = 1 To .HPageBreaks.Count
If .HPageBreaks(i).Location.Value <> "" Then
Do
j = j + 1
If .HPageBreaks(i).Location.Offset(-j).Value = "" Then
.HPageBreaks.Add before:=.HPageBreaks(i).Location.Offset(-j)
j = 0
Exit Do
End If
Loop
End If
Next
（ピンク） 2019/06/24(月) 15:04
Sub test2()
Dim lastrow As Long
Dim i As Long
Dim j As Long
Dim iw As Long
With ActiveSheet
.ResetAllPageBreaks
lastrow = .Range("F" & Rows.Count).End(xlUp).Row
.PageSetup.PrintArea = "$A$1:$F$" & lastrow
iw = .HPageBreaks(1).Location.Row
i = iw
While i < lastrow
For j = i To 3 Step -1
If IsNumeric(.Cells(j, "B").Value) = True Then
.HPageBreaks.Add before:=.Rows(j)
i = j - 1
DoEvents
Exit For
End If
Next j
i = i + iw
Wend
.PrintOut copies:=1, collate:=True
End With
End Sub
（???） 2019/06/24(月) 15:51
別アプローチで改ページ挿入に的を絞って考えてみました。 (このトピ見て、私自身も宿題にしていたのを思い出しましたもので^^;)
全体の改ページ行番号を配列で都度取得しつつ、対象範囲を総当たり という感じです。
Sub test()
Dim v() As Long, r As Long
Dim rowH As Long, rowN As Long
ActiveSheet.ResetAllPageBreaks
v = GetHPageBreakRows(ActiveSheet)
If UBound(v) = 0 Then Exit Sub
For r = 1 To Cells(Rows.Count, "F").End(xlUp).Row
If IsNumeric(Cells(r, 1)) Then '←判定条件
rowH = r
rowN = WorksheetFunction.Lookup(r, v)
Else
If WorksheetFunction.Lookup(r, v) > rowN Then
ActiveSheet.HPageBreaks.Add Cells(rowH, 1)
v = GetHPageBreakRows(ActiveSheet)
End If
End If
Next
End Sub
Private Function GetHPageBreakRows(TargetSheet As Worksheet) As Variant
Dim pb As HPageBreak, v() As Long, i As Long
ReDim v(0 To TargetSheet.HPageBreaks.Count)
If UBound(v) Then
For Each pb In TargetSheet.HPageBreaks
i = i + 1
v(i) = pb.Location.Row
Next
End If
GetHPageBreakRows = v
End Function
（白茶） 2019/06/24(月) 16:04
A列空欄判定なら、Test2の以下を変更でいけそう。
If IsNumeric(.Cells(j, "B").Value) = True Then
↓
If .Cells(j, "A").Value = "" Then
（???） 2019/06/24(月) 16:17
ありゃ。条件変わってたんですね。見落としてました。^^; あと、同じ場所に改ページ追加しまくってたので直しました。
Sub test()
Dim v() As Long, r As Long
Dim rowH As Long, rowN As Long, rowL As Long
ActiveSheet.ResetAllPageBreaks
v = GetHPageBreakRows(ActiveSheet)
If UBound(v) = 0 Then Exit Sub
For r = 1 To Cells(Rows.Count, "F").End(xlUp).Row
If Cells(r, 1) = Empty Then '←判定条件
rowH = r
rowN = WorksheetFunction.Lookup(r, v)
Else
If WorksheetFunction.Lookup(r, v) > rowN Then
If rowH > rowL Then
ActiveSheet.HPageBreaks.Add Cells(rowH, 1)
v = GetHPageBreakRows(ActiveSheet)
rowL = rowH
End If
End If
End If
Next
End Sub
Private Function GetHPageBreakRows(TargetSheet As Worksheet) As Variant
Dim v() As Long, i As Long
ReDim v(0 To TargetSheet.HPageBreaks.Count)
If UBound(v) Then
For i = 1 To UBound(v)
v(i) = TargetSheet.HPageBreaks(i).Location.Row
Next
End If
GetHPageBreakRows = v
End Function
これ、標準ビューのまま実行したらエラーになっちゃいました。 その辺、事前対策が必要かもしれませんね。
（白茶） 2019/06/24(月) 17:29
ピンク様に教えて頂いたコードで試したところうまくいきました。
白茶様、私の今の実力ですと、せっかく提案頂いたのにすぐに内容を理解することが出来ません・・・(><;)時間をかけて内容を理解していきたいと思います。
皆様、お忙しい中大変ありがとうございました。
（いちち） 2019/06/25(火) 09:37
私の説明不足で大変申し訳ありませんでした。
???様が提案して下さったやり方を初めて知り、大変勉強になりました。
ありがとうございました。
（いちち） 2019/06/25(火) 13:57
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.