表を同一処理の回数でコピーするには？

質問

マクロ７級程度（長年初心者）の実力なのですが、仕事の都合上マクロ作成が避けて通れない様なので此方で質問させて戴きます。

A B C D
aaaa 1/25 8 個
bbbb 1/26 16 個
cccc 1/27 8 個

上記の様な表を8個を単位（ロット）として下記のように現場への指示伝票っぽく変更したいのですが、どうすればいいのでしょうか？

F G H I
aaaa 1/25 8 個
bbbb 1/26 8 個
bbbb 1/26 8 個
cccc 1/27 8 個

自分なりに取り組もうとも思ったのですが…

Sub ロットまとめ()

Dim i As Long
For i=『counter』=『start』To『end』Step『step』
Range("A1:D4").Select
Selection.Copy
Range("F4").Select
ActiveSheet.Paste
Next i

End Sub

ご覧の様に、私の今の実力では条件処理など予想だにしなかったのですが、必要に迫られ無謀な取り組みをしています。
既に“For i=…の所でつまずいていますし、「此じゃどういじくっても、一行分しか出来ないのでは？」と感じながらもＶＢＡハンドブックという本を片手に「ハンドブックガイドブックが欲しい！」と半泣きで悪戦苦闘していました。

でも、もう限界……誰か助けて下さい！！！！

回答No.2

nicotinism · ベストアンサー

ロット数で半端なものが有った場合はその分だけ出してます

Sub LotCut()
Dim cutNum As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer

cutNum = InputBox("ロット数は？")
If cutNum = "" Then Exit Sub

i = 1: k = 1

Do Until Cells(i, 3) = ""　　　　　　　　'数値のセルが空白になるまで繰り返し

　　For j = 1 To Cells(i, 3) \ cutNum　　 'ロット数で割った商だけ繰り返し
　　　　Cells(k, 6) = Cells(i, 1)
　　　　Cells(k, 7) = Cells(i, 2)
　　　　Cells(k, 8) = cutNum
　　　　Cells(k, 9) = Cells(i, 4)
　　　　k = k + 1　　　　　　　　　　　　'書き込みする行のカウンタ
　　Next j

　　If Cells(i, 3) Mod cutNum <> 0 Then　'ロット数で割った余りが有る場合
　　　　Cells(k, 6) = Cells(i, 1)
　　　　Cells(k, 7) = Cells(i, 2)
　　　　Cells(k, 8) = Cells(i, 3) Mod cutNum
　　　　Cells(k, 9) = Cells(i, 4)
　　　　k = k + 1
　　End If

　　i = i + 1　　　　　　　　　　 'ロット分けする方の行カウンタ

Loop
Columns("G:G").NumberFormatLocal = "m""月""d""日"";@"
End Sub

お礼

(/oT)ウッウッウッ…

こちらの要望以上のマクロの作成！！！本当にありがとうございます。

マクロの実行の際にロット数を指定できるというのは、他の作業の際にも使う事が出来そうで、本当にありがたいし、勉強になりました。

これから作成いただいたマクロがどうなっているのか勉強させていただきます。

回答No.1

ham_kamo

とりあえず作ってみました。うまく動作しない、あるいは実際はセル範囲が違うとか別のシートに転記とか条件が異なる場合は補足してください。

Sub ロットまとめ()
　　Dim FromRow As Integer 'コピー前の行番号
　　Dim ToRow As Integer 'コピー先の行番号
　　Dim Num As Integer '現在転記中の残りの個数

　　FromRow = 1 '元の表のデータの最初の行番号
　　ToRow = 1 '転記先の最初の行番号
　　Columns("F:I").ClearContents '転記先のセルをクリア
　　'メインループ
　　Do While Cells(FromRow, "A").Value <> ""
　　　　Num = Cells(FromRow, "C").Value '個数を取得
　　　　Do While Num > 0
　　　　　　Cells(FromRow, "A").Resize(1, 4).Copy Cells(ToRow, "F") 'A～D列をF列にとりあずコピー
　　　　　　If Num >= 8 Then
　　　　　　　　Cells(ToRow, "H").Value = 8 '8以上だったらコピー先の個数を8に置きかえ
　　　　　　Else
　　　　　　　　Cells(ToRow, "H").Value = Num '8未満だったらその数に置きかえ
　　　　　　End If
　　　　　　Num = Num - 8
　　　　　　ToRow = ToRow + 1
　　　　Loop
　　　　FromRow = FromRow + 1
　　Loop
End Sub

お礼

ありがとうございます。
お礼が遅れてしまい、申し訳ありません。
作成いただいたマクロは完璧です。

すいません、初めて見るアルファベットの羅列ばかりで…何が何やら…

ご教授いただいたマクロを今から解読していきます。
大変勉強なりますありがとうございました。