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

Question

我在单元格下面插入新行时遇到问题。 我需要在每个活动单元格下面插入新行。 使用此代码，Excel将崩溃。 感谢帮助

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

这将为选定范围拍摄快照，然后在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