根据Cell值插入行并填充

Question

I currently have a sheet with values that look like this, as an example:

1 A     B     C     D..............
2 1     Title of item 1
3       Formulas and formatting 1
4 2     Title of item 2
5       Formulas and formatting 2
6 3     Title of item 3
7       Formulas and formatting 3

What i want to happen is that the code looks up column A. If column A contains a number > 1 then it inserts that number (-1) rows, but 2 rows down. I then need it fill the formulas (the formulas need to be dragged down) and formats down from the row above to the last row inserted for that section. So it would look something like this:

1 A     B     C     D...............
2 1     Title of item 1
3       Formulas and formatting 1
4 2     Title of item 2
5       Formulas and formatting 2
6       Formulas and formatting 2
7 3     Title of item 3
8       Formulas and formatting 3
9       Formulas and formatting 3
10      Formulas and formatting 3

And so on and so.... Note, it needs to drag the entire row formulas and foramts, not just AD...

I think I am almost there with the following code, but I can't get it to fill down from the first row with formulas, under the value in A, until the last row inserted for that section....

Here's my code:

Sub Add_Rows()
  Dim r As Long

  Application.ScreenUpdating = False
  For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
    If Cells(r, "A").Value > 1 Then Rows(r + 2).Resize(Cells(r, "A").Value - 1).Insert

  Next r
  Application.ScreenUpdating = True
End Sub

If any one could help me with the above that would be amazing!! Equally, I think my method might be a bit clumsy, so I am open to more eloquent solutions too!! Thanks Guys, this forum has saved my skin so many times!!! One day I hope I will get to a point where I can maybe answer some questions instead of always asking them!

Answer 1

Try this. You're not actually copying and pasting anything.

Sub Add_Rows()

  Dim r As Long

  Application.ScreenUpdating = False

  For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
    If IsNumeric(Cells(r, "A")) Then
        If Cells(r, "A").Value > 1 Then
            Rows(r + 2).Resize(Cells(r, "A").Value - 1).Insert shift:=xlDown
            Rows(r + 1).Copy
            Rows(r + 2).Resize(Cells(r, "A").Value - 1).PasteSpecial xlPasteAll
        End If
    End If
  Next r

  Application.ScreenUpdating = True
  Application.CutCopyMode = False
  Application.Goto Range("A1")

End Sub