【Excel・マクロ】選択した場所の上に複製したセルを追加するコード

コード

マクロ.xlsm

Sub InsertModifiedCopyAboveSelection()
    Dim selRows As Collection
    Set selRows = New Collection
    
    Dim cell As Range
    Dim rowArray() As Long
    Dim rawData As Long
    Dim i As Long
    Dim insertRow As Long
    Dim lastRowIndex As Long
    Dim minRow As Long, maxRow As Long
    
    minRow = Selection.Cells(1).Row
    maxRow = minRow
    
    
    ' 元の選択範囲の行番号を収集 ＋ 最小/最大行番号の取得
    For Each cell In Selection
        If cell.Row < minRow Then minRow = cell.Row
        If cell.Row > maxRow Then maxRow = cell.Row
    
        On Error Resume Next
        selRows.Add cell.Row, CStr(cell.Row)
        On Error GoTo 0
    Next cell

    ' 拡張範囲の終点を計算： (max - min) * 2 + min
    Dim extendedMaxRow As Long
    extendedMaxRow = (maxRow - minRow) * 2 + minRow
    
    ' 拡張範囲の行番号を selRows に追加
    Dim r As Long
    For r = minRow To extendedMaxRow
        If Not IsInCollection(selRows, r) Then
            selRows.Add r, CStr(r)
        End If
    Next r
    
    
    ' 昇順で並び替えて最初の位置を取得
    ReDim rowArray(1 To selRows.Count)
    Dim item As Variant
    For i = 1 To selRows.Count
        item = selRows(i)
        
        ' 型安全のために明示変換
        rowArray(i) = CLng(item)
    Next i
    Call BubbleSortAscending(rowArray)
    lastRowIndex = UBound(rowArray)

    ' rawData の初期値 = 最小の行番号
    rawData = rowArray(1)

    Do While IsInCollection(selRows, rawData)
        ' 1行上に挿入
        Rows(rawData).Insert Shift:=xlDown
        
        ' コピー元 = rawData + 1（1つ下）
        For i = 1 To ActiveSheet.UsedRange.Columns.Count
            Cells(rawData, i).Value = Cells(rawData + 1, i).Value
        Next i


        ' ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
        ' 複製した行のセルを加工したい場合、この場所に処理を書く
        
        ' ●　加工処理：C列に 2 をセット（例）
        Cells(rawData, 3).Value = 2
        ' ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
        

        ' 次のターゲットへ（+2で次へ）
        rawData = rawData + 2
    Loop

    MsgBox "指定行の上に複製を追加！", vbInformation
End Sub

Function IsInCollection(col As Collection, key As Long) As Boolean
    On Error Resume Next
    Dim dummy As Variant
    dummy = col(CStr(key))
    IsInCollection = (Err.Number = 0)
    Err.Clear
    On Error GoTo 0
End Function

Sub BubbleSortAscending(arr() As Long)
    Dim i As Long, j As Long, temp As Long
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
End Sub

導入

１．マクロの開発画面を表示

Excel上部に開発タブがあるのでクリック
無い場合は、ファイル → オプション → リボンのユーザー設定 → 開発にチェックを入れてOKを押す

開発タブを押したら、１番左にあるVisualBasicをクリック。VisualBasicタブが開く

２．マクロのプログラムをコピペ

VisualBasicの上のタブから、挿入 → 標準モジュールをクリック
マクロのスクリプトをコピペする

３．マクロをショートカットキーで実行できるようにする

Excelの 表示 → マクロ → オプション で好きなショートカットに設定

使い方

複製したい行を複数選択し、実行する

※連続したセルを選択すること。
　連続してないセルの選択には対応していません。