トップ　>　汎用コード　>　一行毎に行挿入・一列毎に列挿入

'セル範囲のセルアドレスを取得しまとめて行（列）を挿入します

Sub Selection_Insert_Rows() '選択セル範囲 1行毎に行を追加する
    If Not TypeName(Selection) = "Range" Then Exit Sub
    Dim i      As Long
    Dim strAds As String
    With Intersect(Selection, ActiveSheet.UsedRange)
        For i = .Rows.Count To 1 Step -1
            strAds = strAds & .Cells(i, 1).Offset(1).Address(False, False) & ","
            If 200 < Len(strAds) Then
                Range(Left$(strAds, Len(strAds) - 1)).EntireRow.Insert
                strAds = ""
            End If
        Next
    End With
    If 0 < Len(strAds) Then
        Range(Left$(strAds, Len(strAds) - 1)).EntireRow.Insert
    End If
End Sub

Sub Selection_Insert_Columns() '選択セル範囲 1列毎に列を追加する
    If Not TypeName(Selection) = "Range" Then Exit Sub
    Dim i      As Long
    Dim strAds As String
    With Intersect(Selection, ActiveSheet.UsedRange)
        For i = .Columns.Count To 1 Step -1
            strAds = strAds & .Cells(1, i).Offset(, 1).Address(False, False) & ","
            If 200 < Len(strAds) Then
                Range(Left$(strAds, Len(strAds) - 1)).EntireColumn.Insert
                strAds = ""
            End If
        Next
    End With
    If 0 < Len(strAds) Then
        Range(Left$(strAds, Len(strAds) - 1)).EntireColumn.Insert
    End If
End Sub