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