ExcelのVBAで繰り返し作業。

質問

http://oshiete1.goo.ne.jp/kotaeru.php3?q=280060

と質問をし、回答をいただき、完成したと思っていたら、追加注文がつきました。

（項目名などが変わっている場合があります。）

まず、一覧表が以下のようになっていたとします。
No　｜　品番　｜　
1　 ｜　11111｜
2　 ｜　22222｜
3　 ｜　33333｜

そして、利用者に、インプットボックスを利用して、
・No（一覧表中の「No」）
・枚数
・No2
・全体数

と入力してもらいます。

結果として

No　｜　品番　｜　No2
2　｜　2222　｜　1212

というような表を3枚作成します。

たとえば、
・No　：　2
・枚数　：　4
・No2　：　1212
・全体数　：　3

と入力してもらったら、
結果は、

No　｜　品番　｜No2
2　｜　2222　｜1212A

No　｜　品番　｜No2
2　｜　2222　｜1212A

No　｜　品番　｜No2
2　｜　2222　｜1212A

というのを4回（枚数文）繰り返し、それが終わったら

No　｜　品番　｜No2
2　｜　2222　｜1212B

というようにNo2のアルファベットを3回（全体数分・今回はCまで）変えて、
上記の作業を繰り返す、というようにしたいのです。

おわかりいただけないかもしれませんが、宜しくお願いします。

回答No.1

nishi6 · ベストアンサー

こんな感じでしょうか。実際に合うように変更して下さい。

Sub printBook2_2()
　　'*** Book、Sheetを定義する ***
　　Dim wb1 As Workbook 'Book1
　　Dim ws11 As Worksheet 'Book1のSheet1
　　　　Set wb1 = ThisWorkbook
　　　　Set ws11 = wb1.Worksheets("Sheet1")
　　Dim wb2 As Workbook 'Book2
　　Dim ws21 As Worksheet 'Book2のSheet1
　　　　Set wb2 = Workbooks("Book2.xls")
　　　　Set ws21 = wb2.Worksheets("Sheet1")

　　'*** 入力する ***
　　Dim myValue
　　Dim iNo As Integer '入力したNo
　　Dim iMaisuu As Integer '入力した枚数
　　Dim iNo2 As Long '入力したNo2
　　Dim ZentaiSuu As Integer '入力した全体数

　　myValue = InputBox("Noを入力します", "(1)No.")
　　　　If myValue = "" Then Exit Sub
　　　　iNo = Val(myValue)
　　myValue = InputBox("枚数を入力します", "(2)枚数")
　　　　If myValue = "" Then Exit Sub
　　　　iMaisuu = Val(myValue)
　　myValue = InputBox("No2を入力します", "(3)No2")
　　　　If myValue = "" Then Exit Sub
　　　　iNo2 = Val(myValue)
　　myValue = InputBox("全体数を入力します", "(4)全体数")
　　　　If myValue = "" Then Exit Sub
　　　　ZentaiSuu = Val(myValue)

　　'*** 入力No.に該当する行を特定する ***
　　Dim fndRg As Range '入力したNoを検索した結果セル
　　Set fndRg = ws11.Range("A:A").Find(what:=iNo, LookAt:=xlWhole)
　　　　'入力No.が見つからなければ終わり
　　　　If fndRg Is Nothing Then
　　　　　　MsgBox "該当No.はありません。"
　　　　　　Exit Sub
　　　　End If

　　Dim zpg As Integer 'カウンタ(全体)
　　Dim pg As Integer 'カウンタ
　　Dim alph As String '品番に付けるアルファベット

　　'*** Book2へ書き出す ***
　　'例として、Book2のSheet1の、
　　'　　B4に『No.』、C4に『品番』、D4に『No2』を表示
　　'　　B9に『No.』、C9に『品番』、D9に『No2』を表示
　　'　　B14に『No.』、C14に『品番』、D14に『No2』を表示
　　'　　表題は既にあるものとする

　　'*** 品番以外の項目をBook2のSheet1に転記する ***
　　With ws21
　　　　.Range("B4") = fndRg.Offset(0, 0)
　　　　.Range("C4") = fndRg.Offset(0, 1)
　　　　.Range("B9") = fndRg.Offset(0, 0)
　　　　.Range("C9") = fndRg.Offset(0, 1)
　　　　.Range("B14") = fndRg.Offset(0, 0)
　　　　.Range("C14") = fndRg.Offset(0, 1)
　　　　For zpg = 1 To ZentaiSuu
　　　　　　'*** 品番に付けるアルファベットを決める ***ZentaiSuu
　　　　　　If ZentaiSuu > 1 Then
　　　　　　　　alph = Chr(64 + zpg)
　　　　　　End If
　　　　　　'*** 項目をBook2のSheet1に転記する ***
　　　　　　.Range("D4") = iNo2 & alph
　　　　　　.Range("D9") = iNo2 & alph
　　　　　　.Range("D14") = iNo2 & alph

　　　　　　For pg = 1 To iMaisuu
　　　　　　　　'今はプレビュー （ .PrintOut で印刷 ）
　　　　　　　　.PrintPreview '.PrintOut
　　　　　　Next
　　　　Next
　　End With
End Sub

補足

回答ありがとうございます。

実はひとつかくのを忘れていました(^^;

1回で3枚の表を出しますが、1回出せば、「1」と表示したいのです。
No1に「4」と入力すれば4回繰り返しますが、その4回繰り返されるごとに
増やしていくのです。

この追加要求が出る前のVBAが下記のようになっていました。
-------------------------------------------------
Sub ボタン4_Click()

Dim NoBox As String
Dim MaisuuBox As String
Dim PonoBox As String
Dim AllNo As String
NoBox = InputBox("Noは？", "No", xpos:=500, ypos:=1500)
Range("inpNo") = NoBox
MaisuuBox = InputBox("枚数は？", "枚数", xpos:=500, ypos:=1500)
Range("inpMaisuu") = MaisuuBox
PonoBox = InputBox("P/O-No.は？", "P/O-No.", xpos:=500, ypos:=1500)
Range("inpPoNo") = PonoBox
AllNo = InputBox("全体で何枚ですか？", "全体数", xpos:=500, ypos:=1500)
Range("inpAllNo") = AllNo

'*** Book、Sheetを定義する ***
Dim wb1 As Workbook 'PACKINGL
Dim ws11 As Worksheet 'PACKINGLのSheet1
Set wb1 = ThisWorkbook
Set ws11 = wb1.Worksheets("部品表")
Set ws12 = wb1.Worksheets("3K600")

'*** 入力No.に該当する行を特定する ***
Dim iNo As Integer '入力したNo
Dim fndRg As Range '入力したNoを検索した結果セル
iNo = ws11.Range("inpNo")
Set fndRg = ws11.Range("B:B").Find(what:=iNo, LookAt:=xlWhole)
'入力No.が見つからなければ終わり
If fndRg Is Nothing Then
MsgBox "該当No.はありません。"
Exit Sub
End If

'*** 入力No.が見つかれば ***
Dim iMaisuu As Integer '入力した枚数
Dim pg As Integer 'カウンタ
Dim alph As String '品番に付けるアルファベット
Dim suuji As String
'枚数のチェックはしない。「Z」まで。
iMaisuu = ws11.Range("inpMaisuu")

'*** Sheet2へ書き出す ***

'*** P/O-Noの項目以外をSheet2に転記する ***
With ws12

'ITEMNo.からITEMNo.へ
'CK部番からPART No.へ
'Q'tyからQ'tyへ
'NetWeightからNetWeightへ

.Range("C7") = fndRg.Offset(0, 1)
.Range("E7") = fndRg.Offset(0, 3)
.Range("F7") = fndRg.Offset(0, 4)
.Range("G7") = fndRg.Offset(0, 5)

.Range("C33") = fndRg.Offset(0, 1)
.Range("E33") = fndRg.Offset(0, 3)
.Range("F33") = fndRg.Offset(0, 4)
.Range("G33") = fndRg.Offset(0, 5)

.Range("C59") = fndRg.Offset(0, 1)
.Range("E59") = fndRg.Offset(0, 3)
.Range("F59") = fndRg.Offset(0, 4)
.Range("G59") = fndRg.Offset(0, 5)

'GROSS WEIGHT
.Range("F3") = "GROSS WEIGHT : " & fndRg.Offset(0, 6)
.Range("F29") = "GROSS WEIGHT : " & fndRg.Offset(0, 6)
.Range("F55") = "GROSS WEIGHT : " & fndRg.Offset(0, 6)

'PALETTE SIZE
.Range("F2") = "PALLETE SIZE : " & fndRg.Offset(0, 7)
.Range("F28") = "PALLETE SIZE : " & fndRg.Offset(0, 7)
.Range("F54") = "PALLETE SIZE : " & fndRg.Offset(0, 7)

For pg = 1 To iMaisuu
'*** P/O-Noに付けるアルファベットを決める ***
If iMaisuu > 1 Then
alph = Chr(64 + pg) '64=Aから　48=1から　47=0から
End If
'*** P/O-No.を表示する ***
.Range("H7") = ws11.Range("inpPoNo") & alph
.Range("H33") = ws11.Range("inpPoNo") & alph
.Range("H59") = ws11.Range("inpPoNo") & alph

If iMaisuu > 1 Then
suuji = CStr(pg) 'Chr=文字　CStr=数値　として扱われる。
End If
'PALLETE No.の横の数字を表示
.Range("D2") = ws11.Range("E3") & suuji
.Range("D28") = ws11.Range("E3") & suuji
.Range("D54") = ws11.Range("E3") & suuji
'今はプレビュー （ .PrintOut で印刷 　.PrintPreviewでプレビュー）
.PrintPreview '.PrintOut

Next
End With

End Sub
-------------------------------------------------

これを教えていただいたようにかえようとして、
以下のようになりました。

-------------------------------------------------
Sub ボタン4_Click()

Dim NoBox As String
Dim MaisuuBox As String
Dim PonoBox As String
Dim AllNo As String
NoBox = InputBox("Noは？", "No", xpos:=500, ypos:=1500)
Range("inpNo") = NoBox
MaisuuBox = InputBox("枚数は？", "枚数", xpos:=500, ypos:=1500)
Range("inpMaisuu") = MaisuuBox
PonoBox = InputBox("P/O-No.は？", "P/O-No.", xpos:=500, ypos:=1500)
Range("inpPoNo") = PonoBox
AllNo = InputBox("全体で何枚ですか？", "全体数", xpos:=500, ypos:=1500)
Range("inpAllNo") = AllNo

'*** Book、Sheetを定義する ***
Dim wb1 As Workbook 'PACKINGL
Dim ws11 As Worksheet 'PACKINGLのSheet1
Set wb1 = ThisWorkbook
Set ws11 = wb1.Worksheets("部品表")
Set ws12 = wb1.Worksheets("3K600")

'*** 入力No.に該当する行を特定する ***
Dim iNo As Integer '入力したNo
Dim fndRg As Range '入力したNoを検索した結果セル
iNo = ws11.Range("inpNo")
Set fndRg = ws11.Range("B:B").Find(what:=iNo, LookAt:=xlWhole)
'入力No.が見つからなければ終わり
If fndRg Is Nothing Then
MsgBox "該当No.はありません。"
Exit Sub
End If

'*** 入力No.が見つかれば ***
Dim iMaisuu As Integer '入力した枚数
Dim pg As Integer 'カウンタ
Dim zpg As Integer
Dim alph As String '品番に付けるアルファベット
Dim suuji As String
Dim iZentaisuu As Integer

'枚数のチェックはしない。「Z」まで。
iMaisuu = ws11.Range("inpAllNo")

'*** Sheet2へ書き出す ***

'*** P/O-Noの項目以外をSheet2に転記する ***
With ws12

'ITEMNo.からITEMNo.へ
'CK部番からPART No.へ
'Q'tyからQ'tyへ
'NetWeightからNetWeightへ

.Range("C7") = fndRg.Offset(0, 1)
.Range("E7") = fndRg.Offset(0, 3)
.Range("F7") = fndRg.Offset(0, 4)
.Range("G7") = fndRg.Offset(0, 5)

.Range("C33") = fndRg.Offset(0, 1)
.Range("E33") = fndRg.Offset(0, 3)
.Range("F33") = fndRg.Offset(0, 4)
.Range("G33") = fndRg.Offset(0, 5)

.Range("C59") = fndRg.Offset(0, 1)
.Range("E59") = fndRg.Offset(0, 3)
.Range("F59") = fndRg.Offset(0, 4)
.Range("G59") = fndRg.Offset(0, 5)

'GROSS WEIGHT
.Range("F3") = "GROSS WEIGHT : " & fndRg.Offset(0, 6)
.Range("F29") = "GROSS WEIGHT : " & fndRg.Offset(0, 6)
.Range("F55") = "GROSS WEIGHT : " & fndRg.Offset(0, 6)

'PALETTE SIZE
.Range("F2") = "PALLETE SIZE : " & fndRg.Offset(0, 7)
.Range("F28") = "PALLETE SIZE : " & fndRg.Offset(0, 7)
.Range("F54") = "PALLETE SIZE : " & fndRg.Offset(0, 7)

For zpg = 1 To iZentaisuu

'*** P/O-No.を表示する ***

If iZentaisuu > 1 Then
alph = Chr(64 + zpg)
End If

.Range("H7") = ws11.Range("inpPoNo") & alph
.Range("H33") = ws11.Range("inpPoNo") & alph
.Range("H59") = ws11.Range("inpPoNo") & alph

For pg = 1 To iMaisuu
'*** P/O-Noに付けるアルファベットを決める ***
If iMaisuu > 1 Then
suuji = CStr(pg) 'Chr=文字　CStr=数値　として扱われる。
End If

'PALLETE No.の横の数字を表示
.Range("D2") = ws11.Range("E3") & suuji
.Range("D28") = ws11.Range("E3") & suuji
.Range("D54") = ws11.Range("E3") & suuji

'今はプレビュー （ .PrintOut で印刷 　.PrintPreviewでプレビュー）
.PrintPreview '.PrintOut
Next

Next
End With

End Sub
-------------------------------------------------
でもこれを実行しても何も起こりません。

一体どこが違うのでしょうか？

宜しくお願いします。

回答No.2

nishi6

＞でもこれを実行しても何も起こりません。
＞一体どこが違うのでしょうか？

iZentaisuuに値が代入されていないようです。見ただけのチェックで確認していません。

'枚数のチェックはしない。「Z」まで。
iMaisuu = ws11.Range("inpAllNo")

　　　　　　　　↓　下のように修正して、１行追加。

'枚数のチェックはしない。「Z」まで。
iMaisuu = ws11.Range("inpMaisuu")
iZentaisuu = ws11.Range("inpAllNo")

のようにしてみて下さい。

お礼

すっかり抜けていたのですね(^^;

おかげさまでできました！！
ありがとうございました。