Inserting multiple rows based on criteria and copy-paste new data

[Beatrix]

Hi Everyone,

I have a list in Excel 2013. I need to insert a new row at the end of every 3 rows and copy-paste new data into column D and E in new rows. Columns A B C should be filled with the same information which repeats in previous rows. I attached a sample spreadsheet with before/after scenarios.

Can anyone help me on this please?

Cheers.
B.

[p45cal]

Try on your sample sheet:

Sub blah()
Sheets("before (2)").Delete
Sheets("before").Copy After:=Sheets(2)
Range("A1").CurrentRegion.Subtotal GroupBy:=1, Function:=xlMin, TotalList:=Array(1), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
With Range("A1").CurrentRegion
  .ClearOutline
  .Columns("A:A").Delete
  With .Columns("B:B").SpecialCells(xlCellTypeBlanks)
    .FormulaR1C1 = "=R[-1]C"
    .Offset(, 1).FormulaR1C1 = "=R[-1]C"
    .Offset(, 2).FormulaR1C1 = Range("H2").Value
    .Offset(, 3).FormulaR1C1 = Range("I2").Value
  End With
  .Rows(.Rows.Count).Delete
  .Value = .Value
End With
Columns("E:E").EntireColumn.AutoFit
End Sub

[mancubus]

i would personally use p45cal's code. it not only is neater but also deals with different number of repetitions in column A.

below very simple code (which i wrote last night but gave up posting it after seeing p45cal's neater code ) works only with static number of repeats in col A.

Sub vbax_52858_insert_blank_rows_every_nth_row_fill_from_above()

    Dim i As Long, HeaderRow As Long, nth As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    HeaderRow = 1 'HeaderRow = 0 if there is no header row
    nth = 3
    
    Worksheets("before").Copy After:=Worksheets("before")
    With ActiveSheet
        .Name = "before_new"
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        
        For i = (LastRow + 1) To (HeaderRow + nth) Step -nth
            Rows(i).Insert
        Next i
        
        LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
        
        For i = (HeaderRow + nth) To LastRow
            If .Range("A" & i).Value = "" Then
                .Range("A" & i).Value = .Range("A" & i - 1).Value
                .Range("B" & i).Value = .Range("B" & i - 1).Value
                .Range("C" & i).Value = .Range("C" & i - 1).Value
                .Range("D" & i).Value = .Range("H2").Value
                .Range("E" & i).Value = .Range("I2").Value
            End If
        Next i
    End With
        
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

[Beatrix]

Hi p45cal

Thanks very much for the code. It works perfect. However I didn't understand the first line below. Is it for deleting worksheet "before"? When I run the code it pops a message to delete worksheet "before" when I press cancel it runs; if I press ok it deletes sheet "before" then gives an error.

Sheets("before (2)").Delete

Try on your sample sheet:

Sub blah()
Sheets("before (2)").Delete
Sheets("before").Copy After:=Sheets(2)
Range("A1").CurrentRegion.Subtotal GroupBy:=1, Function:=xlMin, TotalList:=Array(1), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
With Range("A1").CurrentRegion
  .ClearOutline
  .Columns("A:A").Delete
  With .Columns("B:B").SpecialCells(xlCellTypeBlanks)
    .FormulaR1C1 = "=R[-1]C"
    .Offset(, 1).FormulaR1C1 = "=R[-1]C"
    .Offset(, 2).FormulaR1C1 = Range("H2").Value
    .Offset(, 3).FormulaR1C1 = Range("I2").Value
  End With
  .Rows(.Rows.Count).Delete
  .Value = .Value
End With
Columns("E:E").EntireColumn.AutoFit
End Sub

[david000]

Hi p45cal

Thanks very much for the code. It works perfect. However I didn't understand the first line below. Is it for deleting worksheet "before"? When I run the code it pops a message to delete worksheet "before" when I press cancel it runs; if I press ok it deletes sheet "before" then gives an error.

'Sheets("before (2)").Delete

It looks like he created a dummy test sheet manually by clicking and dragging and then wrote the code and tweaked it after every run. You can comment that line out and get a new sheet each run with a new name "before (2)", (3), etc.


Perhaps unrelated but worth noting is the names of these two macros.

Sub blah()'Where am I?

Sub vbax_52858_insert_blank_rows_every_nth_row_fill_from_above() 'Oh, THAT post!

[Beatrix]

got it. thanks very much David.