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