エクセルで自動連番

質問

いろいろ調べてもわからなかったので、教えてください。
複数行コピー＆自動連番の操作についてです。
sheet1に以下の表を作成しました。

　　Ａ　　　　　　　　　Ｂ　　　　　Ｃ　　　　　　　Ｄ
1|【グループＩＤ】　【品名】　　【個別ＩＤ】　　【数量】
2|　　001　　　　　　Aセット　　　　10001　　　　　5
3|　002　　　　　　　Bセット　　　　20001　　　　　2

マクロで複数行コピーを行い、sheet2に

　　　A　　　　　　　　B　　　　　　C　　　　　　　D
1|【グループＩＤ】　【品名】　【個別ＩＤ】　【数量】
2|　001　　　　　　　Aセット　　　　10001　　　　　5
3|　001　　　　　　　Aセット　　　　10001　　　　　5
4|　001　　　　　　　Aセット　　　　10001　　　　　5
5|　001　　　　　　　Aセット　　　 10001　　　　　5
6|　001　　　　　　　Aセット　　　　10001　　　　　5
7|　002　　　　　　　Bセット　　　　20001　　　　　2
8|　002　　　　　　　Bセット　　　　20001　　　　　2

の表を作成することはできたのですが、できれば【個別ＩＤ】を
　　Ａ　　　　　　　　Ｂ　　　　　　Ｃ　　　　　　　Ｄ
1|【グループＩＤ】　【品名】　　【個別ＩＤ】　　【数量】
2|　001　　　　　　　Aセット　　　　10001　　　　　5
3|　001　　　　　　　Aセット　　　　10002　　　　　5
4| 001　　　　　　　Aセット　　　　10003　　　　　5
5|　001　　　　　　　Aセット　　　　10004　　　　　5
6|　001　　　　　　　Aセット　　　　10005　　　　　5
7|　002　　　　　　　Bセット　　　　20001　　　　　2
8|　002　　　　　　　Bセット　　　　20002　　　　　2

という形でマクロで複数行コピーと組み合わせて自動で採番まで行いたいと思っています。

ちなみコードは、完全に自分で組む事はできないですが、コードの内容を理解して改造できる程度です。
よろしくお願いします。

回答No.4

kybo · ベストアンサー

Rows(idx + 1).Resize(.Value - 1).Insert Shift:=xlDown

の直後に以下の一文を入れてオートフィルで書き換えるのが簡単な気がします。

Range("C" & idx).AutoFill Destination:=Range("C" & idx).Resize(.Value), Type:=xlFillSeries

お礼

ありがとうございます！！
ずばり思った通りのことができました！！
大変助かりました

回答No.5

merlionXX

No2 merlionXXです。
ご提示されたコードを見ても、何も言及のないK列が出てきたりでさっぱりわかりません。

Sheet1のA1:D1以下にある表を、とりあえずSheet2に「数量」分だけ広げて、それを新しいBOOKにすればいいんですよね？

一例です。

Sub test02()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Set myRng = s1.Range("A1:D1")
Do Until myRng(1) = ""
With s2
x = IIf(.Cells(Rows.Count, "B").End(xlUp).Value = "", 1, .Cells(Rows.Count, "B").End(xlUp).Row + 1)
myRng.Copy .Cells(x, "A")
If IsNumeric(myRng(4).Value) Then
Set cpRng = .Range("B" & x & ":C" & x)
cpRng.AutoFill Destination:=cpRng.Resize(myRng(4).Value, 2), Type:=xlFillDefault
.Range("A" & x & ":A" & x + myRng(4).Value - 1).Value = .Range("A" & x).Value
End If
Set myRng = myRng.Offset(1)
End With
Loop
Sheets("Sheet2").Copy
ActiveWorkbook.SaveAs Filename:=Format(Now, "YYYY年MM月DD日hh：mm") & ".xls"
ActiveSheet.Name = "ラベル"
ActiveWorkbook.Close
End Sub

お礼

本当にありがとうございます。
わざわざコードまで書いていただいてしまって・・・=_=；。
いろいろと説明が悪すぎて、混乱させてしまったようです。

実際の表はK列に数量が入っていて、sheet1は"ラベル"になったままで、
しかもsheet2が存在せず、SHEET1をコピーしてシートを作る構造になってました。

すみませんでした。。。

回答No.3

imogasi

こんなの考えかたは基本的で、内容も簡単と思うが。
コピー貼り付け後にＩＤの同じ行の間は個別ＩＤを１増やして、Ｆｏｒｍａｔ関数ででも（文字列化したらしまい）
グループＩＤが変わったとき、個別ＩＤをどういうルールで振るのか書いてないが。
ＩＤが変わったかどうかは、１行前のＩＤを記録する変数を持って、ＩＦ文で現在行のそれと比較したらしまい。

補足

実は個別IDはロッド番号で、実際制作ものは個別IDが２つあります。

（というのはAセット２つで１組のもので後々分かれる可能性があるからです。分かれた後もグループIDで集められなければならないんです・・・）

グループ内では規則正しい連番ですが、別のグループに移った場合は関連がないんです・・・。
極端な話、グループ001がAセットで10001から始まって10005で終わっても、
次のグループ002もAセットで31023から31025といった場合があります。

回答No.2

merlionXX

Sheet1の表とSheet2の表の関連がわかりません。
Sheet1にある数量の数だけ行を増やすのかとも思いましたが、Sheet2の各商品の数量はそれぞれ5でかわってないようですし・・・。

ちゃんと転記する条件を明示するか、Sheet2に貼り付けたマクロのコードを提示するかしないと正しい回答はできないと思います。
（ほんとはSheet2では数量はそれぞれ１にしたいのではないのかとか憶測はしていますが）

補足

＃１さん、＃２さん、回答ありがとうございます。

＃１さんからの回答を見て、ちょうどコードを貼り付けようとしていたところでした。
書き漏らしていたのですが、実はsheet1にマクロのボタンが存在します。
なのでマクロのボタンがそのまま残るのは不都合な為、
sheet2に一端計算したものを、値のみ貼り付けて別なbookに貼り付けて保存を行っています。
書き方が悪かったのですが、数量はコピーするための数量で、削除を行ってもよいのですが、きちんと指定数コピーされているか確認の為、残してあるだけです。ちなみに実際のコードは以前に他の方が複数行コピーで質問されたものを少々変えて使っています。

Sub test01()

Dim sc As Integer
Dim idx As Integer

Application.ScreenUpdating = False
sc = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1

ThisWorkbook.Sheets("ラベル").Cells.Copy
Workbooks.Add
Sheets("sheet1").Range("A1").PasteSpecial Paste:=xlValues
Sheets("sheet1").Range("A1").PasteSpecial Paste:=xlFormats
Sheets("sheet1").Name = "ラベル"

For idx = Range("A64436").End(xlUp).Row To 1 Step -1
With Cells(idx, "k")
If IsNumeric(.Value) Then
If .Value > 1 Then
Rows(idx).Copy
Rows(idx + 1).Resize(.Value - 1).Insert Shift:=xlDown
End If
End If

End With
Next idx
Application.CutCopyMode = False
Application.SheetsInNewWorkbook = sc
ActiveWorkbook.SaveAs Filename:=　Format(Now, "YYYY年MM月DD日hh：mm") & ".xls"
ActiveWorkbook.Close
ThisWorkbook.Close saveChanges:=False

End Sub

です。

回答No.1

Trick--o--

１．貼り付ける回数を取得する
２．対象となる行をコピーする
３．取得した回数だけ貼り付ける
４．コピーするデータが残っていれば１に戻る

こういう手順でやっているとしたら、３と４の間に
3.5．個別IDを1増やす
を追加する感じで。