再）excel2000VBAで用紙の上半分部分のみ連続印刷する

質問

ここで教えていただいた、コードを実行したところ見事連続印刷できましたが、シートの上半分が10枚に印刷されます。10枚だと用紙がもったいないので、2シートづつＡ４で5枚に収めて印刷したいです。それにはどうしたらよろしいか。ご教示お願いします。

Sub TesSample()
Dim mySh As Variant
'請求書一括印刷
mySh = Array("ＡＡＡ", "ＢＢＢ", "ＣＣＣ", "ＤＤＤ", "ＥＥＥ", "ＦＦＦ", "ＧＧＧ", "ＥＥＥ", "ＦＦＦ", "ＧＧＧ")

Worksheets(mySh).Select
Worksheets(mySh).PrintPreview
Worksheets("hyousi").Select
End Sub

回答No.1

Wendy02 · ベストアンサー

こんばんは。Wendy02です。

このマクロは、前々回からの続きのマクロを直したものです。プロテクトは、パスワードは後でつけてください。
確か、プリンタの吐き出しを制御する方法があったはずですが、今、私の所のプリンタはありませんもので、実験が出来ません。それから、これは、縮小されたものか、B4サイズの紙のようですね。そうでないと、64行までは印刷できませんから。

Sub BillsTotalPrintProc2()
　 '請求書一括印刷
　 Dim mySh As Variant
　 Dim i As Long
　 Application.ScreenUpdating = False
　 '請求印刷面のデータの削除
　 Worksheets("請求印刷 (2)").UsedRange.Clear
　 '開始
　 mySh = Array("A", "B", "C", "D", "E", "F", "G", "I", "J")
　 For i = LBound(mySh) To UBound(mySh)
　　　 Worksheets(mySh(i)).Unprotect　'プロテクトを外す
　　　 Worksheets(mySh(i)).Range("B2:AB32").Copy _
　　　 Worksheets("請求印刷 (2)").Cells((i + 1) + 32 * i, 1)
　　　 Worksheets(mySh(i)).Protect　　'プロテクトを掛ける
　 Next
　 Application.CutCopyMode = False

　 Worksheets("請求印刷 (2)").PrintPreview
　 Application.ScreenUpdating = True
　 Sheets("hyousi").Select
End Sub

'---------------------------------
'既に設定済みの場合は、以下は入りません。行の高さ－列の幅をコピーするマクロです。
'ハングしたかと思うほど、ひじょうに時間が掛かります。すでに、セルの高さ・幅が設定されていたら、これは必要ありません。

Sub PrintPageSetting()
　 '印刷ページ設定
　 Dim myRowsData As Variant
　 Dim myColumnsData As Variant
　 Dim i As Integer
　 Dim j As Integer
　 Dim k As Integer
　 'コピーされたシートの数
　 Const SH_COUNT = 10
　 Application.ScreenUpdating = False
　 With Worksheets("A").Range("B2:AB32")
　　　ReDim myRowsData(1 To .Rows.Count)
　　　ReDim myColumnsData(1 To .Columns.Count)
　　　For i = 1 To .Rows.Count
　　　　 myRowsData(i) = .Cells(i, 1).RowHeight
　　　Next
　　　For j = 1 To .Columns.Count
　　　　 myColumnsData(j) = .Cells(1, j).ColumnWidth
　　　Next
　　　For j = 1 To .Columns.Count
　　　　 Worksheets("請求印刷 (2)").Cells(1, j).ColumnWidth _
　　　　　　= myColumnsData(j)
　　　Next
　　　For k = 1 To SH_COUNT:　 For i = 1 To .Rows.Count
　　　　 Worksheets("請求印刷 (2)").Cells(i + (SH_COUNT - 1) * 32, 1).RowHeight _
　　　　　　= myRowsData(i)
　　　　 Next:　 Next
　　　End With

　　　Application.ScreenUpdating = True
End Sub

お礼

あありがとうございました。完璧にできました。
なんとお礼をもうしていいか言葉がみつかりません。
私の質問にこんなにも労力を使っていただいて恐縮しています。ただただ感謝のきもちです。
おっしゃるとおり、自分の作ったものを見たら85％に縮小されていたので、そのように変更したらばっちりでした。これからもご指導よろしくお願いします。