Excel VBA-为活动单元格插入新行

Question

I have a problem with insert new row below cell. I need to insert new row below each active cell. With this code Excel will crash. Thanks for help

Sub CopyRow()

    Dim cel As Range
    Dim selectedRange As Range

    Set selectedRange = Application.Selection

    For Each cel In selectedRange.Cells
        cel.Offset(1, 0).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
        'copy data
         cel.Offset(1, 0 ).Value = cel.Value
    Next cel

End Sub

Answer 1

This takes a snapshot of the selected range, then works backwards on the UsedRange:

---

Option Explicit

Public Sub CopyRows()
    Dim sRng As Range, sRow As Long, sr As Variant
    Dim r As Long, lb As Long, ub As Long

    Set sRng = Application.Selection
    sRow = sRng.Row
    If sRng.CountLarge = 1 Then
        With ActiveSheet.UsedRange
            .Rows(sRow + 1).EntireRow.Insert Shift:=xlShiftDown
            .Rows(sRow + 1).Value2 = .Rows(sRow).Value2
        End With
    Else
        sr = sRng
        lb = LBound(sr)
        ub = UBound(sr)
        Application.ScreenUpdating = False
        With ActiveSheet.UsedRange
            For r = ub To lb Step -1
                .Rows(r + sRow).EntireRow.Insert Shift:=xlShiftDown
                .Rows(r + sRow).Value2 = .Rows(r + sRow - 1).Value2
            Next
            .Rows(lb + sRow - 1 & ":" & ub * 2 + sRow - 1).Select
        End With
        Application.ScreenUpdating = True
    End If
End Sub