サクッとコピペ ExcelVBA

サクッとコピペして、使えるVBAコード集

行をコピーして1行当たりの行数を複数行に増やすマクロ(VBA)

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

f:id:suguruyoshida38:20160925211534p:plain

実際は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

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

f:id:suguruyoshida38:20160925215613p:plain

2)考え方はExcelを1行コピーして複数行にペーストする次のやり方をべーすにしてマクロを組んでいます。

f:id:suguruyoshida38:20160925214837p:plain

プライバシーポリシーはこちら