Question

有人可以帮助我调整此代码以解决我的问题吗？

我有一个按钮，可以从A5向下添加x数量的新行。列A-Z。

我希望新行为空白，但仍包含下拉菜单和公式。 VBA的新手，正在为此苦苦挣扎。

我认为我需要更改范围并添加xlPasteFormulas，但不确定两者的位置和方式。任何帮助深表感谢。

Option Explicit

Sub AddRows()

    Dim x As Integer

    x = InputBox("How many rows would you like to add?", "Insert Rows")

    'Selecting range to insert new cells
    Range(Cells(5, 1), Cells(x + 4, 1)).EntireRow.Insert

    'Copys current cell A6 and past in the new cells
    Cells(x + 5, 1).Copy Range(Cells(5, 1), Cells(x + 4, 1))

    'if you want the cells to be blank but still have the drop down options
    Range(Cells(5, 1), Cells(x + 4, 1)).ClearContents

End Sub

Answer 1

请尝试以下代码。它将复制BaseRow中的所有内容，然后删除该范围内的常量值，并保留格式，包括数据验证和公式。

Sub AddRows()

    Const BaseRow As Long = 11   ' 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

该代码现在具有紧急出口：如果您未在InputBox中输入任何内容，则该过程终止。请注意，新行将插入BaseRow上方。插入后，所有新行和旧行都相同。然后，您可以选择将常量保留在这些行的第一行或最后一行，这实际上意味着在BaseRow上方或下方插入新的空白行。

VBA公式以公式添加新行

1 个答案: