Excel vba – inserire una nuova row per le celle attive

Ho un problema con inserire una nuova row sotto la cella. Devo inserire una nuova row sotto each cella triggers. Con questo codice Excel si blocca. Grazie per l'aiuto

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 

Solutions Collecting From Web of "Excel vba – inserire una nuova row per le celle attive"

Questo prende un'istantanea dell'intervallo selezionato, quindi funziona all'indietro sulla UseRange:


 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