Excelで、あるセルの値に応じて行を自動挿入したい

スクリーンショットのようなExcelデータがあるとします。これをD列の数字に応じて、コピー行をその数字の数（D2のでしたらA2からH2の267個のコピーを挿入したいです）だけ作りたいのです。もちろん、手作業で「コピー→行挿入」を繰り返せばできますが、データ量が多いため大変です。これを簡単に行う方法はないでしょうか。ご回答お待ちしております。

質問者からの補足コメント

• はい、D3についてその通りです。コピー先はその行の下に挿入コピーする形にしたいです。シートは同じもの大丈夫です。Excelに慣れていないもので、説明不足で申し訳ありません。

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/10/27 21:50

• 

  はいVBAを使っていただいて問題ありません。間違いありません。D列の数字の分だけ行を追加したいです。宜しくお願いします。

  No.2の回答に寄せられた補足コメントです。 補足日時：2017/10/27 22:28

No.5 回答者： tom04 回答日時： 2017/10/27 23:14

こんばんは！

すでに回答は出ていますが・・・
コピー＆ペーストにするとかなりの時間を要すると思います。
値の代入にしてみました。

元データはSheet1にあり、Sheet2に表示するとしています。
標準モジュールにしてください。

Sub Sample1()
Dim i As Long, j As Long, lastRow As Long
Dim myRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet1")
With Worksheets("Sheet2")
lastRow = .Cells(Rows.count, "A").End(xlUp).row
If lastRow > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow, "H")).ClearContents
End If
For i = 2 To wS.Cells(Rows.count, "A").End(xlUp).row
myRow = .Cells(Rows.count, "A").End(xlUp).row + 1
For j = 1 To 8 '//A列～H列まで//
If wS.Cells(i, "D") > 0 Then
.Cells(myRow, j).Resize(wS.Cells(i, "D") + 1).Value = wS.Cells(i, j).Value '//★//
Else
.Cells(myRow, j).Value = wS.Cells(i, j).Value
End If
Next j
Next i
.Activate
End With
MsgBox "完了"
End Sub

※　仮にD列に「3」という数値がある場合、同じデータが4行できるコトになりますが、
これで良いのでしょうか？

もし、D列の行数だけ！というのであれば、コード内の「★」の行を
＞.Cells(myRow, j).Resize(wS.Cells(i, "D")).Value = wS.Cells(i, j).Value

としてみてください。m(_ _)m

この回答へのお礼

3の場合は3行だけにしたかったので、その方法も示していただきとても助かりました。ありがとうございました。

お礼日時：2017/10/28 11:40

No.4 回答者： GooUserラック 回答日時： 2017/10/27 22:54

こんな感じはいかがですか？

-----------------------------------------------------------------------------------------
Sub Sample()
Dim 行 As Long
Dim 残数 As Long
Application.ScreenUpdating = False
For 行 = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
残数 = Cells(行, 4).Value
Do While 残数 > 0
Range(Cells(行, 1), Cells(行, 8)).Copy
Range(Cells(行, 1), Cells(行, 8)).Insert Shift:=xlDown
残数 = 残数 - 1
Loop
Next
Application.ScreenUpdating = True
End Sub
-----------------------------------------------------------------------------------------
※ 行追加の場合は下から行う方が、行番号が変化しないのでお勧めです。
※「Application.ScreenUpdating = False」と「Application.ScreenUpdating = True」は画面書き換えを停止させスピードアップを図っています。

この回答へのお礼

こちらの方法もしっかり機能しました。本当にありがとうございます。

お礼日時：2017/10/28 11:38

No.3 回答者： tatsu99 回答日時： 2017/10/27 22:10

同じシートにした場合、リラン（マクロの再実行）ができなくなるので、Sheet2へコピーするようにしました。

Sheet2が正しく作成されているのを確認後、Sheet2のシート名を正しいものに変えてください。
下記マクロを標準モジュールへ登録してください。
マクロ実行時は、提示された画面が表示されている状態で実行してください。
マクロは、アクティブシートのデータをコピーします。
----------------------------------------------------------------------
Option Explicit

Public Sub 行コピー()
Dim ws As Worksheet
Dim maxrow As Long
Dim row As Long
Dim row2 As Long
Dim count As Long
Dim i As Long
Set ws = Worksheets("Sheet2")
ws.Cells.Clear
maxrow = Cells(Rows.count, "D").End(xlUp).row
Rows(1).Copy ws.Rows(1)
row2 = 2
For row = 2 To maxrow
count = Cells(row, "D").Value + 1
For i = 1 To count
Rows(row).Copy ws.Rows(row2)
row2 = row2 + 1
Next
Next
MsgBox ("コピー完了")
End Sub

この回答へのお礼

丁寧なご回答をありがとございました。しっかり挿入＆コピーができました。

お礼日時：2017/10/28 11:37

No.2 回答者： GooUserラック 回答日時： 2017/10/27 21:54

マクロ（ＶＢＡ）を使っても良いのでしょうか？

Ｄ列の数字は元の行を追加する数だと思いますが間違いないですか？

No.1 回答者： tatsu99 回答日時： 2017/10/27 21:24

D3については、A3：H3を２０個コピーすればよいのですか？

コピー先は、どこですか。同じシートの最後ですか。それとも、別なシートですか。別なシートの場合は、行ごとにシートが変わるのですか。
コピー先について、具体的な例を提示してください。

この回答へのお礼

はい、D3についてその通りです。コピー先はその行の下に挿入コピーする形にしたいです。シートは同じもの大丈夫です。Excelに慣れていないもので、説明不足で申し訳ありません。

お礼日時：2017/10/27 21:43