根據Cell值插入行並填充

Question

我目前有一張表格看起來像這樣的表格，作為一個例子：

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

我想要發生的是代碼查找列A.如果列A包含一個> 1的數字，那么它將插入該數字（-1）行，但是向下插入2行。 然后我需要填充公式（需要拖動公式）並從上面的行向下格式化為該部分插入的最后一行。 所以它看起來像這樣：

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

等等......注意，它需要拖動整個行公式和foramts，而不僅僅是AD ...

我想我差不多有以下代碼，但是我不能讓它從第一行填充公式，在A中的值，直到為該部分插入的最后一行....

這是我的代碼：

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

如果任何人可以幫助我上面的那將是驚人的！ 同樣，我認為我的方法可能有點笨拙，所以我也願意接受更有說服力的解決方案！ 謝謝大家，這個論壇已經多次保存了我的皮膚！ 有一天，我希望我能夠回答一些問題，而不是總是問他們！

Answer 1

嘗試這個。 你實際上並沒有復制和粘貼任何東西。

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