VBA从表中插入带有公式的新行

Question

我有VBA代码向表中添加新行（数据从第5行开始）。

我制作了一张新表，当表没有标题时它工作得很好。但是，当我添加标题时，会弹出以下错误

运行时错误'1004'这将无法工作，因为它会移动工作表上的表格中的单元格。

我点击调试，它突出显示Rng.Insert Shift:=x1Down

错误的原因是什么？如何纠正？

Sub AddRows()

    Const BaseRow As Long = 5   ' modify to suit

    Dim x As String             ' InputBox returns text if 'Type' isn't specified
    Dim Rng As Range
    Dim R As Long

    x = InputBox("How many rows would you like to add?", "Insert Rows")
    If x = "" Then Exit Sub
    R = BaseRow + CInt(x) - 1

    Rows(BaseRow).Copy          'Copy BaseRow
    'specify range to insert new cells
    Set Rng = Range(Cells(BaseRow, 1), Cells(R, 1))
    Rng.Insert Shift:=xlDown

    ' insert the new rows BEFORE BaseRow
    ' to insert below BaseRow use Rng.Offset(BaseRow - R)
    Set Rng = Rng.Offset(BaseRow - R - 1).Resize(Rng.Rows.Count, ActiveSheet.UsedRange.Columns.Count)
    Rng.Select
    On Error Resume Next
    Rng.SpecialCells(xlCellTypeConstants).ClearContents
    Application.CutCopyMode = False '
End Sub

Answer 1

我认为你的表是一个列表对象。然后，以下代码可能会起作用

Sub TestAdd()
Dim myTbl As ListObject
Dim x As String
Dim i As Long

    Set myTbl = Sheet1.ListObjects(1)
    x = InputBox("How many rows would you like to add?", "Insert Rows")

    If x = "" Then Exit Sub
    For i = 1 To CInt(x)
        myTbl.ListRows.Add (1)
    Next i
End Sub

更新：为了保持格式和公式，您可以使用以下代码

Sub TestAdd()

Dim myTbl As ListObject
Dim x As String
Dim i As Long
Dim newRow As Range
Dim sngCell As Range

    Set myTbl = Sheets("Rentals").ListObjects(1)
    x = InputBox("How many rows would you like to add?", "Insert Rows")
    If x = "" Then Exit Sub
    For i = 1 To CInt(x)
        Set newRow = myTbl.ListRows.Add(1).Range
        With newRow
            .Offset(1).Copy
            ' .PasteSpecial xlPasteFormulasAndNumberFormats
            .PasteSpecial xlPasteFormulas
            .PasteSpecial xlPasteFormats
            For Each sngCell In newRow
                If Not (sngCell.HasFormula) Then
                    sngCell.ClearContents
                End If
            Next
        End With
        Application.CutCopyMode = False
    Next i
End Sub