EXCEL VBA 複数シートを指定回数印刷

質問

お世話になります。

添付の様なEXCELがあります。

[管理シート]が一番左にあって、[商品番号]毎のシートが右にずらっと並んできます。

[管理シート]には「商品番号」(B4)と「商品名」(C4)と「数量」(D4)が記述されています。
商品数は可変で、増えたり減ったりします。それに伴いシートも増減します。
この商品番号は不規則にブランクがあったりしますので、この場合は読み飛ばしたいのです。

(管理シートの商品番号と商品番号シートの関係を分かり易くするため添付画像では黄色に塗りつぶしてあります)

■やりたい事
[管理シート]に「印刷」というボタンを作成します。

この「印刷」ボタンがクリックされたら、商品番号をチェックして、この商品番号と同じシートを開いてその「数量」に記述されている数字 + 1の回数分、選択されたシートを印刷したいのです。
（わかりづらくてスイマセン・・)

例)D1 ピーナッツパンならD1シートを7(6+1)回印刷したい

ただし、[管理シート]の「商品番号」と「商品番号」のシートの順番は一致しないため、管理シートの商品番号を順にチェックするたびに[管理シート]以外の全シートを毎回READする必要があるかと思います。

会社でこの様な仕事を依頼されて、困っています。
どなたかご教授いただけませんでしょうか？
よろしくお願い致します。

環境 WindowsXP SP3
Ｅｘｃｅｌ2003

回答No.3

tom04 · ベストアンサー

続けてお邪魔します。

＞もしB列と同じ名称のシート名がなかったら「処理を中止します・・・

というより、スルーするようにしてみました。
（B列にあるSheetのみ印刷する）

Private Sub CommandButton1_Click()
Dim i As Long, k As Long, str As String, myFlg As Boolean
For i = 5 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "B") <> "" And Cells(i, "D") > 0 Then
str = Cells(i, "B")
For k = 1 To Worksheets.Count
If Worksheets(k).Name = str Then
myFlg = True
Exit For
End If
Next k
If myFlg = True Then
If MsgBox(str & "シートを" & Cells(i, "D") + 1 & "部印刷しますか？", vbYesNo) = vbYes Then
Worksheets(str).PrintOut copies:=Cells(i, "D") + 1
End If
End If
End If
myFlg = False
Next i
End Sub

こんな感じではどうでしょうか？m（_ _）m

お礼

tom04さん、早速のご連絡ありがとうございます！

ご教授いただきましたロジックで出来ました！！
本当に助かりました！
これで会社から依頼された通りの仕組みが出来ました。

いつもいつも本当にありがとうございます！！

回答No.2

tom04

No.1です。

＞インデックスが有効範囲にありません

おそらくSheetが存在しないためのエラーだと思います。
前回のコードはB列がSheet名になっているという前提のコードですので、
そうでない場合は他の方法でSheetを指定する方法が必要になります。

この程度しかお答えできないのですが、
各Sheetを指定できる材料があれば具体的なコードも提示できると思います。m(_ _)m

補足

tom04さん、おはようございます。
またまたご連絡ありがとうございました！

tom04さんが仰る通り、B列と同じ名称のSheetが存在していないためのエラーでした。
もしB列と同じ名称のシート名がなかったら「処理を中止します」といった感じで処理を中止にするようなロジックは可能でしょうか？

何度も申し訳ございませんがよろしくお願い致します。

回答No.1

tom04

こんにちは！

「管理シート」のB列がSheet名と解釈して良いのですかね？
そういうコトだとしての一例です。
「管理シート」にコマンドボタンを配置し、それをクリックするとします。
↓のコードにしてみてください。

Private Sub CommandButton1_Click()
Dim i As Long, str As String
For i = 5 To Cells(Rows.Count, "B").End(xlUp).Row
If Cells(i, "B") <> "" And Cells(i, "D") > 0 Then
str = Cells(i, "B")
With Worksheets(str)
If MsgBox(str & "シートを" & Cells(i, "D") + 1 & "部印刷しますか？", vbYesNo) = vbYes Then
.PrintOut copies:=Cells(i, "D") + 1
End If
End With
End If
Next i
End Sub

※　数量を少なくして試してみてください。
（紙がもったいないため）

こんな感じではどうでしょうか？m（_ _）m

補足

tom04さん、ありがとうございます！
いつもありがとうざいます！！

早速実行してみましたところ、下記のようなエラーが出てしまいました・・・

Worksheets(str)=<インデックスが有効範囲にありません>

申し訳ございませんが、再度お知恵をお借りできませんでしょうか？

よろしくお願い致します。