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.