エクセルでレコードを自動作成するには？

質問

エクセル中級？者です。マクロをかじった程度ですが、
下記のパターンでレコードを自動追加作成するのに、簡単な方法はありますか？

項目　　　　　　商品　　　　数量　
レコード1　　　　　　Ａ　　　　　３　　　　
レコード2　　　 　　 Ｂ　　　　　２
　　　　　　　　↓
レコード1　　　　　　Ａ　　　　　１
レコード2　　　　　　Ａ　　　　　１
レコード3　　　　　　Ａ　　　　　１
レコード4　　　　　　Ｂ　　　　　１
レコード5　　　　　　Ｂ　　　　　１

商品別の n個の合計データより、単品毎ｎ個のレコードを自動作成したいのです。
合計データだけでも2,000程あり、×約5レコードで10,000はコピーするだけでも大変で、なんとかエクセルのマクロ等で自動作成できないものでしょうか？　
シートやブックが変わっても結構です。宜しくお願いします。

回答No.2

imogasi · ベストアンサー

関数でやってみました。
例データ　A1:D７（データはA,B列、CD列は下記で説明）
商品名 数量 0 a
a 3 4 b
b 2 6 c
c 4 10 d
d 3 13 f
f 2 15 g
g 5 20
C2に式
=SUM($B$2:B2)+1
と入れてC7まで式を複写。
C1に０を入れる。
D1：D6にA2:A7の値を複写する。
E1に
=VLOOKUP(ROW(),$C$1:$D$7,2,TRUE)
といれて、式を第２０－１行まで複写する。
結果　E1:E19に
a
a
a
b
b
c
c
c
c
d
d
d
f
f
g
g
g
g
g
となる。質問者のケースに合わせて修正してください。
コピーは、行数が多いので、＋ハンドルを引っ張るのでなく、CTRL+C（コピー元・１セル）,CTRL+V（コピー先・多数セル指定）でやってください。

お礼

教えて頂いた通りに応用すると、摩訶不思議に見事問題がクリアしました。
VLOOKUPがこんな風に使えるとは、大変勉強になりました。
どうも有り難うございました。

回答No.1

Wendy02

こんばんは。

話が見えていない部分があるので、こちらで考えました。

"レコード1" が、なぜ、変ってしまうのか、よく分りませんし、まさか、数字を取り去っるなんていう話ですと、かなりややこしくなるかと思います。一応、定数として、(BASENAME=)「レコード」を使いました。考え方は、分るはずですから、後は、ご自身で加工してみてください。

'<標準モジュール推奨>
Sub CopyPasteByCount()
　 Dim c As Range
　 Dim Sh1 As Worksheet
　 Dim Sh2 As Worksheet
　 Const BASENAME As String = """レコード"""
　 Set Sh1 = Worksheets("Sheet1") 'ソース側
　 Set Sh2 = Worksheets("Sheet2") 'ペースト側

　 Application.ScreenUpdating = False

　 For Each c In Sh1.Range("C1", Sh1.Range("C1").End(xlDown))
　　　If IsNumeric(c.Value) Then
　　　　 With Sh2.Range("A65356").End(xlUp).Offset(1)
　　　　　　.Resize(c.Value, 1).FormulaLocal = "=" & BASENAME & "& ROW()-1"
　　　　　　.Resize(c.Value, 1).Value = .Resize(c.Value, 1).Value
　　　　　　.Offset(, 1).Resize(c.Value, 1).Value = c.Offset(, -1).Value
　　　　　　.Offset(, 2).Resize(c.Value, 1).Value = 1
　　　　 End With
　　　End If
　 Next c

　 Sh2.Rows(1).Delete '最後に、一行目を削除
　 Set Sh1 = Nothing: Set Sh2 = Nothing
　 Application.ScreenUpdating = True
End Sub

お礼

まだまだ、勉強が足りません。
ご丁寧に有り難うございました。