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