行をコピーして１行当たりの行数を複数行に増やすマクロ（VBA）

単純なものでも、はまってしまう時ははまってしまうのがマクロです。先日、職場の人からこんなマクロ（VBA）の相談を受けました。

実際は1000行くらいあり、列も20列くらいあったのですが、単純な作業といえば単純な作業です。最初できたのはこんなコードでした。

＜ちょっとカッコ悪いコード＞

Sub 連続して4行に増やす()
   '最終行の取得
    Dim LstRow As Long
    LstRow = Cells(Rows.Count, 1).End(xlUp).Row
   '繰り返し処理
    For i = LstRow To 2 Step -1
        Rows(i).Select
        Application.CutCopyMode = False
        Selection.Copy
        Selection.Insert Shift:=xlDown
        Selection.Copy
        Selection.Insert Shift:=xlDown
        Selection.Copy
        Selection.Insert Shift:=xlDown
    Next
End Sub

このコードだと、3行ふやしたり、4行増やしたりといった調整にいちいちVBAのコードをいじらなければなりません。そこで汎用的なコードを作成しました。

＜汎用的なコード＞

Sub 同一行コピーを増やして連続させる()
    'A列最終行の取得（LstRow　=　Cells（）の中の1を調整。Bなら2）
    Dim LstRow As Long
    LstRow = Cells(Rows.Count, 1).End(xlUp).Row
   '最終的な行数をInputBoxから取得
    Dim a As Long
    a = Application.InputBox("最終的に何行にしますか？", Type:=1)
   'InputBoxの引数が2より小さ場合、終了する。
    If a < 2 Then
           MsgBox "有効でない数値が入力されました。"
        End
    End If
   'aを増やす行数に変換する。
    a = a - 1
   '繰り返し処理（見出し行ありを「LastRow to 2」で調整、見出しがなければ「to 1」）
    For i = LstRow To 2 Step -1
        Rows(i).Select
        Selection.Copy
        Rows(i + 1 & ":" & i + a).Select
        Selection.Insert Shift:=xlDown
    Next
End Sub

１）InputBoxが開いて、最終的な行数を入力すれば良いので楽です。

f:id:suguruyoshida38:20160925215613p:plain