[[20180303124226]]　『定形書式帳簿の印刷とデータ転記について』（PCL）　ページの最後に飛ぶ

『定形書式帳簿の印刷とデータ転記について』（PCL）

お世話になります。

定形書式の帳簿印刷について2つ質問ががあります。

１　印刷範囲について

印刷するページは入力データにより変化(1ページから5ページ程度)します。

下記コードで、最終行の取得と印刷範囲の選択までは出来ましたが、改ページ時の印刷範囲の選択が分かりません。

行数は1ページ20行で決まっており、21行目にデータがある場合2ページ目は40行目まで印刷したいのです。

基準が6になっているのは6列目には必ずデータが入っているからです。

Sub 帳簿印刷()

With Worksheets("帳簿印刷")

Dim j As Long, myArr As Range

j = .Cells(Rows.Count, 6).End(xlUp).Row
Set myArr = Range("A1:I" & j)
.PageSetup.PrintArea = myArr.Address
.PrintPreview
End With
Set myArr = Nothing

End Sub

２　改ページ時の表記について
同じ帳簿へデータを転記する際、ページが変わった時(各ページの1行目のみ)に上のデータと同じ場合「同上」と記載していたものを元のデータとして記載する場合はどうしたらいいでしょうか？

例として

番号　名前　品目
111　青木　りんご
111　同上　同上　　←同じページ内なら同上とする

改ページ

111　青木　りんご　←改ページしたら改めて表示する

コードは下記の通りです。

With Worksheets("帳簿印刷")
Dim Wr As Variant

Wr = .Cells(Rows.Count, 6).End(xlUp).Offset(1).Row

.Range("E" & Wr).Value = TexDay.Text
.Range("G" & Wr).Value = TextJyusyo.Text
.Range("H" & Wr).Value = TexBangou.Text
.Range("H" & Wr + 1).Value = TexSei.Text + " " + TexMei.Text
.Range("G" & Wr + 1).Value = TextKankei.Text + " " + TextSimei.Text
.Range("F" & Wr).Value = TextHin1.Text + " " + TextKazu1.Text

    If TextHin2.Text = "" Then
    Exit Sub
    End If
.Range("F" & Wr + 1).Value = TextHin2.Text + " " + TextKazu2.Text
    If TextHin3.Text = "" Then
    Exit Sub
    End If

.Range("F" & Wr + 2).Value = TextHin3.Text + " " + TextKazu3.Text
.Range("G" & Wr + 3).Value = "同　上"
.Range("H" & Wr + 3).Value = "同　上"

    If TextHin4.Text = "" Then
    Exit Sub
    End If

見苦しいコードかもしれませんがどうぞよろしくお願いします。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

＞１　印刷範囲について

jを20で割り算して、切り上げたら印刷ページ数になりませんか

＞２　改ページ時の表記について

条件付き書式で、下記を満たすとき、同上と表示させてはどうでしょうか。
・上のセルと同じ値
・行番号を20で割り算した余りが１でない
・空白でない

（マナ） 2018/03/03(土) 13:09

＞・行番号を20で割り算した余りが１でない

これは不要でした。
21,41,61,81行目に条件付き書式を設定しなければよいだけでした。

（マナ） 2018/03/03(土) 13:39

 なるべく原案を維持しながら、気になるところを修正しつつ
想像力をMaxにして
Sheet1に元データがあるとして　帳簿印刷シート　にて
20行毎に改ページを追加してその行の値が直上と同じだったら　同上　とします。
同じと判断するところはE列からI列としました。
どうでしょうか？
Option Explicit
Sub 帳簿印刷()
Dim j As Long, myArr As Range
Dim Wr As Long
Dim i As Long
Dim jj As Long
Dim MyA As Variant
With Worksheets("Sheet1")
    j = .Cells(Rows.Count, 6).End(xlUp).Row
    Set myArr = .Range("A1:I" & j)
    MyA = myArr.Value
    Wr = .Cells(Rows.Count, 6).End(xlUp).Offset(1).Row
    For i = 1 To Wr
        If i Mod 20 = 0 Then
            For jj = 5 To UBound(MyA, 2)
                If MyA(i, jj) = MyA(i - 1, jj) Then
                    MyA(i, jj) = "同上"
                End If
            Next
        End If
    Next
 '    .HPageBreaks(1).Location = .Range("e10")

 '    .Range("E" & Wr).Value = TexDay.Text
 '    .Range("G" & Wr).Value = TextJyusyo.Text
 '    .Range("H" & Wr).Value = TexBangou.Text
 '    .Range("H" & Wr + 1).Value = TexSei.Text + " " + TexMei.Text
 '    .Range("G" & Wr + 1).Value = TextKankei.Text + " " + TextSimei.Text
 '    .Range("F" & Wr).Value = TextHin1.Text + " " + TextKazu1.Text

 '    If TextHin2.Text = "" Then
 '        Exit Sub
 '    End If
 '    .Range("F" & Wr + 1).Value = TextHin2.Text + " " + TextKazu2.Text
 '    If TextHin3.Text = "" Then
 '        Exit Sub
 '    End If

 '    .Range("F" & Wr + 2).Value = TextHin3.Text + " " + TextKazu3.Text
 '    .Range("G" & Wr + 3).Value = "同　上"
 '    .Range("H" & Wr + 3).Value = "同　上"

 '    If TextHin4.Text = "" Then
 '        Exit Sub
 '    End If
End With
With Sheets("帳簿印刷")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA
    .PageSetup.PrintArea = myArr.Address
    .ResetAllPageBreaks
    For i = 1 To UBound(MyA, 1)
        If i Mod 20 = 0 Then
            .HPageBreaks.Add .Range("A" & i + 1)
        End If
    Next
End With
Set myArr = Nothing
Erase MyA
End Sub
（SoulMan） 2018/03/03(土) 14:40

 すみません
最初のループも
For i = 1 To Wr
⬇
For i = 1 To UBound(MyA, 1) 
としないとデータによってはエラーとなるでしょうから
変更してください
となると、
 >なるべく原案を維持しなが
が、微妙ですけど、、
（SoulMan） 2018/03/03(土) 15:11

 >同じ帳簿へデータを転記する際、
 >ページが変わった時(各ページの1行目のみ)に
 >上のデータと同じ場合「同上」と記載していたものを
 >元のデータとして記載する場合はどうしたらいいでしょうか？

 よくよく読み返してみますと改ページした一行目のみ
同上　ではなくデータその物が欲しいと言うことみたいですね
と言うか、そう書いてある？日本語は難しい(^^;

 トピ主さんのコードに変数や　wrに+3　しているあたりから想像すると
元データの同上となっているところから遡って　○○　と書いてある
内容を表示したいと言うことみたいですね？

 印刷した時の一行目が　同上　では、何かわからない　と言う
ことと想像力をMaxにしてみました。

 改ページした一行目で　同上　となっている場合のみ　遡って探索　に
配列と　その行を渡して　同上となっている元のデータを取得します。
どうでしょうか？

 Option Explicit
Sub 帳簿印刷()
Dim j As Long, myArr As Range
Dim i As Long
Dim jj As Long
Dim MyA As Variant
Dim x As Variant
Dim v As Variant
With Worksheets("Sheet1")
    j = .Cells(.Rows.Count, 6).End(xlUp).Row
    Set myArr = .Range("A1:I" & j)
    MyA = myArr.Value
    For i = LBound(MyA, 1) To UBound(MyA, 1)
        If i Mod 20 = 1 Then
            For jj = 5 To UBound(MyA, 2) - 1
                If MyA(i, jj) = "同上" Then
                    x = Application.Index(MyA, 0, jj)
                    v = Empty
                    遡って探索 x, i, v
                    MyA(i, jj) = v
                End If
            Next
        End If
    Next
End With
With Sheets("帳簿印刷")
    .Cells.Clear
    .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA
    .PageSetup.PrintArea = myArr.Address
    .ResetAllPageBreaks
    For i = LBound(MyA, 1) To UBound(MyA, 1)
        If i Mod 20 = 0 Then
            .HPageBreaks.Add .Range("A" & i + 1)
        End If
    Next
End With
Set myArr = Nothing
Erase MyA, x
MsgBox "処理が完了しました"
End Sub
Sub 遡って探索( _
    ByVal x As Variant, _
    ByVal i As Long, _
    ByRef v As Variant)
    For i = i To LBound(x, 1) Step -1
        If x(i, 1) <> "同上" Then
            v = x(i, 1)
            Exit Sub
        End If
    Next
End Sub
v(=∩_∩=)v
（SoulMan） 2018/03/03(土) 21:17

マナさん

その通りなんですが、それをコードにする力量がなく・・・
参考にして考えてみます。

ありがとうございました。
（PCL） 2018/03/03(土) 22:01

SoulManさん

説明不足ですいませんでした。
言葉で伝えるのって難しいですね・・・

直近に頂いた回答の通り、定形書式の帳簿でページをまたいだ場合、ページの一番上に同上が来るのはまずかろう、
ということでした。

で、伝え忘れていたんですが、帳簿は１ページ２０行あって、入力項目の関係で必ず２行ずつ増えて行くので、ループさせたりすればいいのかなーと、頭ではわかっているんですが、なかなか形(コード)にすることが出来ないでおります。

作成していただいたコードについては、使ったことのないコードが多々あり、理解するのに時間がかかるかと思いますが試してみたいと思います。

比較的試すのが簡単そうな印刷コードだけ試してみましたが、実行すると定形書式の罫線などが消えてしまうのと、入力した行までしか範囲が選択されず、思った通りの結果になりませんでした。

ただ、きちんとコードを理解せずにコピペして実行しただけなのでこれから色々試してみたいと思っています。

ありがとうございました。
（PCL） 2018/03/03(土) 22:14

＞その通りなんですが、それをコードにする力量がなく・・・

 Option Explicit

 Sub 帳簿印刷()
    Dim j As Long
    Dim p As Long

    With Worksheets("帳簿印刷")
        j = .Cells(Rows.Count, 6).End(xlUp).Row
        p = WorksheetFunction.RoundUp(j / 20, 0)
        .PrintOut 1, p, Preview:=True
    End With

 End Sub

後は、手作業で、条件付き書式を設定しておくだけです。

（マナ） 2018/03/03(土) 22:25

 >直近に頂いた回答の通り、
 >定形書式の帳簿でページをまたいだ場合、
 >ページの一番上に同上が来るのはまずかろう、 
 >ということでした。 
想像力Maxは大体あってましたね(;^_^A

 >帳簿は１ページ２０行あって、入力項目の関係で必ず２行ずつ増えて行くので、
この考え方が微妙ですけど、20→24→26→28
と増えるとして、取り敢えず　E列～H列　の改行一行目に同上がある場合、
その列の直上にある同上以外のデータを取得します。

 >実行すると定形書式の罫線などが消えてしまう
これは、ClearをClearContentsにしましたので消えないと思います。
試してみてください。
では、では、

 Option Explicit
Sub 帳簿印刷()
Dim j As Long, myArr As Range
Dim i As Long
Dim jj As Long
Dim 改ページ As Long
Dim n As Long
Dim MyA As Variant
Dim x As Variant
Dim v As Variant
With Worksheets("Sheet1")
    j = .Cells(.Rows.Count, 6).End(xlUp).Row
    Set myArr = .Range("A1:I" & j)
    MyA = myArr.Value
    改ページ = 20
    n = 0
    For i = LBound(MyA, 1) + 1 To UBound(MyA, 1)
        If i Mod 改ページ = 1 Then
            For jj = 5 To UBound(MyA, 2) - 1
                If MyA(i, jj) = "同上" Then
                    x = Application.Index(MyA, 0, jj)
                    v = Empty
                    遡って探索 x, i, v
                    MyA(i, jj) = v
                End If
            Next
            n = n + 2
            改ページ = 改ページ + 20 + n
        End If
    Next
End With
改ページ = 20
n = 0
With Sheets("帳簿印刷")
    .Cells.ClearContents
    .Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA
    .PageSetup.PrintArea = myArr.Address
    .ResetAllPageBreaks
    For i = LBound(MyA, 1) To UBound(MyA, 1)
        If i Mod 改ページ = 0 Then
            .HPageBreaks.Add .Range("A" & i + 1)
            n = n + 2
            改ページ = 改ページ + 20 + n
        End If
    Next
End With
Set myArr = Nothing
Erase MyA, x
MsgBox "処理が完了しました"
End Sub
Sub 遡って探索( _
    ByVal x As Variant, _
    ByVal i As Long, _
    ByRef v As Variant)
    For i = i To LBound(x, 1) Step -1
        If x(i, 1) <> "同上" Then
            v = x(i, 1)
            Exit Sub
        End If
    Next
End Sub
v(=∩_∩=)v
（SoulMan） 2018/03/03(土) 23:41

コメント返信：

[ 一覧(最新更新順) ]

[[20180303124226]] 『定形書式帳簿の印刷とデータ転記について』（PCL） ページの最後に飛ぶ

[[20180303124226]]　『定形書式帳簿の印刷とデータ転記について』（PCL）　ページの最後に飛ぶ