16 November 2008

(Excel) セルの値に基づき、行コピー

Excelで、「あるセル」に入力されている数値の分だけ、その行を複製コピーするVBAスクリプト。

例えば、こういう場合に使う。

         A      B      C      D   
1商品名個数シリアル番号
2○○○10
3△△△5

商品1個ずつシリアル番号が必要なため、個数の数だけ行を増やした後、「シリアル番号」を連番入力するという風な作業をしたい時。 手で行コピー、張りつけを繰り返すよりは、スクリプトで自動化…

Sub test1() Dim i As Integer Dim nTemp As Integer Dim nEmptyLine As Integer nEmptyLine = 0 For i = 1 To 10000 If TypeName(Cells(i, "B").Value) = "Empty" Then '個数セルが『空白』の場合、空白カウンタをインクリメント nEmptyLine = nEmptyLine + 1 '『空白』が4行以上続いたら、処理中断 If nEmptyLine > 3 Then Exit For End If Else '空白カウンタをリセット(『空白』以外のセルが出現したため) nEmptyLine = 0 '個数セルの内容を数値に変換して一時変数に代入 nTemp = Val(Cells(i, "B").Value) If nTemp > 1 Then '行コピー Range(Rows(i), Rows(i)).Copy '行挿入&ペースト Range(Rows(i), Rows(i + nTemp - 1)).Insert '挿入行数分だけ、処理行を進める i = i + nTemp End If End If Next i End Sub

※ 閲覧者からの指摘がありました。意図した行数+1行コピーされてしまうようです。Excelの実環境を持っていないので、検証不可です、すいません。(2016年9月追記)