Copy row and insert between existing rows with relative formula kept

[m-steele]

I am trying copy multiple rows of data and insert it between every existing row of data in my sheet.

You can see this in the attached document. Look in the sheet "Mainsails"

Row 3 and Row 4 should be copied and inserted between rows 5 and 6, 6 and 7, 7 and 8, etc. The formula must maintain relative reference.

This must copy the cell formulas not the values. It must also copy the whole row not just the first column.

I have he following macro which almost works but the inserted formula is exactly as it was copied and I need it to be relative. As in change the formula based on where the formula is inserted.

Currently if the formula in the cell refers to L2 the formula copied also contain L2.

I need the formula to change the reference so it matches with the row above it. Another words if the cell is inserted 10 rows below where it was copied it needs to reference L12 instead of L2.

I think this is called relative reference.

Im not sure how to change this so that it maintains relative reference. Here is what i got so far.

Sub insertFormulas()
  Dim x
    Application.ScreenUpdating = 0
     x = Cells(3, 1).Resize(2, 50).Formula
      For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
    j = 1
    Do Until j > 2
        Cells(i, 1).EntireRow.Insert
        j = j + 1
    Loop
    Cells(i, 1).Resize(2, 50).Formula = x
      Next
    Application.ScreenUpdating = 1
End Sub

Thank you for any help!

[p45cal]

1. I suspect the formula in cell K3 needs to change from:

="[ADD]"&ROUND(SUM(('Mainsails (2)'!I2*('Sail Pricing'!B25))+('Mainsails (2)'!I2*('Sail Pricing'!H25))),2)

to:

="[ADD]"&ROUND(SUM(('Mainsails (2)'!I2*('Sail Pricing'!B$25))+('Mainsails (2)'!I2*('Sail Pricing'!H$25))),2)

2. Try:

Sub blah()
Application.ScreenUpdating = 0
For i = Cells(Rows.Count, 2).End(xlUp).Row To 5 Step -1
    Rows("3:4").Copy
    Rows(i + 1).Insert Shift:=xlDown
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = 1
End Sub

A bit slow, but it should solve your problem.

[Teeroy]

m-steele,

Just replace the .Formula with .FormulaR1C1 in your code. This should keep the relative references.

[m-steele]

Thanks guys both of those solutions did the trick.

Only one problem. They are both incredably slow and as they process the excel documents gets very slow over time.

I assume this is because the document starts to have 15000 plus rows.

I stopped the process because i wasn't sure if it was working. Turns out after about 7 hours it had only got about half way through the document.

Just inserting a single row now loads my computer up for about 10 to 15 seconds. This i assume is why its going so slow? its taking almost a whole minute to insert one instance of the copied data.

Is there a way to deal with this?

In addition how would i modify the code so i could continue where i stopped the last macro? It was on row 3278. It processes from bottom to the top so i still have 3278 rows to go. I want to start from row 3278 but am not sure how to change the code or select a range for a macro.

Thanks

[p45cal]

See http://vbaexpress.com/kb/getarticle.php?kb_id=1035 for speed up routines.
You could also add a couple of lines; somewhere within the loop:

Application.statusbar = "i = " & i

and just before the end:

Application.StatusBar = False

..which will give you an update on the status bar of the workbook.

To continue half way through, the line:

For i = Cells(Rows.Count, 2).End(xlUp).Row To 5 Step -1

can be changes to:

For i = 3278 To 5 Step -1

but make a note of that start row so you can check manually it's done it properly.

[Teeroy]

For the new starting point replace the following line

For i = Cells(Rows.Count, 2).End(xlUp).Row To 5 Step -1

with

For i = 3278 To 5 Step -1

The slowness is strange through may have something to do with the first resize statement or automatic calculation. Try the following and if it's still slow then remove the comments on the Application.calculation lines.

Sub insertFormulas() 
    Dim x 
    Application.ScreenUpdating = 0 
'Application.Calculation = xlCalculationManual
    x = Range("A3:AX4").FormulaR1C1 
    For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1 
    j = 1 
    Do Until j > 2 
        Cells(i, 1).EntireRow.Insert 
        j = j + 1 
    Loop 
    Cells(i, 1).Resize(2, 50).FormulaR1C1 = x 
    Next 
    Application.ScreenUpdating = 1 
'Application.Calculation = xlCalculationAutomatic
End Sub

[p45cal]

Another thing you can try is creating a new sheet where no rows are inserted, but it's built up from the top down.
For this to work, there needs to be a change to the formula in K9 of the Mainsails sheet. Currently the formula has cell refs. that refer to the sheet they're on:

="[ADD]"&ROUND(SUM((Mainsails!I2*('Sail Pricing'!B25))+(Mainsails!I2*('Sail Pricing'!H25))),2)

these need to be removed:

="[ADD]"&ROUND(SUM((I2*('Sail Pricing'!B25))+(I2*('Sail Pricing'!H25))),2)

then the following macro should work properly. It creates a new sheet with a date/time stamp in the name.

Sub insertMain2()
Dim x
Application.ScreenUpdating = 0
Application.Calculation = xlCalculationManual
Set newsht = Sheets.Add
newsht.Name = "Mainsails " & Format(Now, "YYYY MMM D  hh_mm")
Set oldsht = Sheets("MainSails")
With oldsht
    LR = .Cells(.Rows.Count, 2).End(xlUp).Row
    .Rows("1:4").Copy newsht.Rows("1:4")
    newsht.Cells(3, 1).Resize(2, 50).Formula = oldsht.Cells(3, 1).Resize(2, 50).Formula
End With
With newsht
    x = .Cells(3, 1).Resize(2, 50).FormulaR1C1
    For i = 5 To LR
        DestRw = (i - 5) * 3 + 5
        oldsht.Range(oldsht.Cells(i, 1), oldsht.Cells(i, 50)).Copy .Cells(DestRw, 1)
        .Cells(DestRw + 1, 1).Resize(2, 50).FormulaR1C1 = x
    Next i
End With
Application.ScreenUpdating = 1
Application.Calculation = xlCalculationAutomatic
End Sub

See how you get on, but do check the formulae are all OK. Then you can delete the original and rename the new one.