Excel VBA 連番印刷

質問

昨日以下の質問をさせていただいた者です。

http://okwave.jp/qa/q8349562.html
こちらで教えていただいた以下のコードに、
J2のセルに連番を振るコードを付け足したいと思い、
同じくこちらのサイトの過去の履歴にあった以下コードを参考にとやってみているのですが、
Next で指定された変数の参照が無効です。と言われてしまいます…

印刷部数の指定はいらず、sheet印刷のJ2セルに1から始まる連番を振りたいのです。

どのように修正をしたらいいのかご教示願います。

Sub Sample4()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents
Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("B6") = wS3.Cells(i, "A")
Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible)
Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible)
myArea1.Copy
wS2.Activate
ActiveSheet.Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues
myArea2.Copy
wS2.Activate
ActiveSheet.Range("J10").Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
'Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

連番印刷のコード

Sub NumberPrint()
Dim idx As Integer
Dim res
　res = Application.InputBox("印刷部数を入力してください", Type:=1)
　If res > 0 Then
　　For idx = 1 To res
　　　Range("AW3").Value = idx
　　　ActiveSheet.PrintOut
　　Next idx
　End If
End Sub

回答No.2

tom04 · ベストアンサー

No.1です。

印刷枚数の連番をご希望だった！というコトですね。
VPageBreakオブジェクトなどを利用して、改ページの回数を参考にしてみたのですが、

結局1からの連番ではなく、そのSheetの総ページ数しか表示できないようです。

ただ、これでは何もお役に立てないので、苦肉の策として、ヘッダーで対応してはダメですか？

ヘッダーの編集で　&[ページ番号]/&[総ページ数]
とすれば、とりあえずは　各項目ごとの総ページ数に対する何ページ目か？は表示できると思います。

全部のページ枚数は表示できませんが、この程度しか思いつきません。
ごめんなさいね。m(_ _)m

お礼

いえいえ、度々助けていただいて感謝です。
ありがとうございます。
はじめヘッダーでやったんですが、
やはり印刷枚数で出したくて…
でもこれで本当に十分満足です！
ありがとうございました！

回答No.1

tom04

こんばんは！
前回回答した者です。

＞sheet印刷のJ2セルに1から始まる連番を振りたいのです。

J2セルに連番というコトはいくら行数が多くて何ページになっても1度しか印刷されないので
前回の質問だと「200」の場合に「1」・「300」の場合に「2」・・・
という感じの連番になればよいのですよね？
（印刷枚数ではない！という解釈）

そうであれば単純に1行だけ追加すれば大丈夫だと思います。
前回のコードの○行と△行の間！といっても行数が多いので、もう一度コードを載せてみます。
（★マークのところを追加しただけです）

Sub Sample5()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents
Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("J2") = i - 1 '←★この行のみ追加★
wS2.Range("B6") = wS3.Cells(i, "A")
Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible)
Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible)
myArea1.Copy
wS2.Activate
ActiveSheet.Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues
myArea2.Copy
wS2.Activate
ActiveSheet.Range("J10").Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut
Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub

こんな感じではどうでしょうか？m(_ _)m

補足

tom04さま、こんばんは！
昨日に引き続きありがとうございます。
印刷したものを配布回収するので回収の際の漏れチェックに、
と思い連番を振りたかったので、＝印刷枚数で教えていただきたいです。
自分でやってみたのですが全て「1」になってしまい、
途方に暮れています…

また本日セル番地と転記後の値をクリア（書式はそのまま）のコードを追加し以下のようになっております。

遅い時間に申し訳ありませんが、
明日提出しなければならなくて焦っております。

どうかよろしくお願いいたします。

Sub Sample4()
Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range
Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("DB")
Set wS2 = Worksheets("印刷")
Set wS3 = Worksheets("Sheet3")
endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True
wS1.Range("A:A").Copy wS3.Range("A1")
wS1.ShowAllData
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row
If endRow2 > 9 Then
Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents
Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents
End If
wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
wS2.Range("J2") = i - 1 '←★この行のみ追加★
wS2.Range("B2") = wS3.Cells(i, "A")
Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible)
Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible)
myArea1.Copy
wS2.Activate
ActiveSheet.Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues
myArea2.Copy
wS2.Activate
ActiveSheet.Range("J4").Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row

Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut

Range("B4:J503").ClearContents

Next i
wS1.AutoFilterMode = False
wS3.Cells.Clear
End Sub