Question

我最近发布了一个问题，遗憾的是没有得到任何答案。我重新制作了我的宏来镜像我在其他地方找到的类似场景。问题是我现在陷入困境。

宏的目的： 1.在所选单元格下方，我需要插入x新行=输入月-1

在第一个插入的行中，我需要一组相对公式，可以在当前工作表的实际行2中找到（基本上将第2行复制并粘贴到创建的第一行）
< / LI>
在随后插入的行中，我需要一组可在当前工作表的实际行3中找到的相对公式

按原样，宏执行我想要的操作，但我不知道如何在所有后续行中粘贴第3行。我假设我需要一些条件陈述？

正如我在上一篇文章中提到的，我正在尝试自学VBA，所以任何帮助都会受到赞赏!!

Sub InsertMonthsAndFillFormulas(Optional vRows As Long = 0)
Dim x As Long
ActiveCell.EntireRow.Select  'So you do not have to preselect entire row
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
  "Enter the total number of months in the program", Title:="Add Months", _
  Default:=1, Type:=1) 'Default for 1 row, type 1 is number
If vRows = False Then Exit Sub
End If

Dim sht As Worksheet, shts() As String, i As Long
ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
   Windows(1).SelectedSheets.Count)
i = 0
For Each sht In _
   Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name

x = Sheets(sht.Name).UsedRange.Rows.Count 'lastcell fixup

Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
 Resize(rowsize:=vRows - 1).Insert Shift:=xlDown

Rows(2).EntireRow.Copy Destination:=Selection.Offset(1).Resize( _
     rowsize:=1)
Rows(3).EntireRow.Copy Destination:=Selection.Offset(2).Resize( _
     rowsize:=1)
On Error Resume Next
Next sht
Worksheets(shts).Select
End Sub

Answer 1

好的，根据您的评论，以下代码应满足您的需求。但首先，需要注意几点。

我添加了几条评论，以帮助您了解代码中发生的情况。
根据您对vRows的评论，如果用户保留默认输入框值（“1”），代码现在将终止。逻辑是如果值只有一个，则不需要添加任何行。 请注意，我从Inputbox值中减去1。
代码假定您在第一行中有标题或至少填充的单元格。我使用第一行来查找最后使用的列。
如果在执行此代码时有可能激活错误的工作表，请取消注释我的代码的第16行。（显然，您需要更改代码以反映您的工作表名称。
最后，此代码假定数据集的左上角位于A1。

在示例数据集上测试

Sub InsertMonthsAndFillFormulas(Optional vRows As Long = 0)

Dim lastCol As Long
Dim r As Range

'Ask user for number of months.
'If the user keeps the default value (1), exit sub.
If vRows = 0 Then
    vRows = Application.InputBox(prompt:= _
        "Enter the total number of months in the program", Title:="Add Months", _
        Default:=1, Type:=1) - 1
    If vRows = 0 Then Exit Sub
End If

'Uncomment this line if you are concerned with which sheet needs to be active.
'ThisWorkbook.Sheets("YourSheet").Select

With ActiveSheet
    'Set the range to work with as the cell below the active cell.
    Set r = ActiveCell.Offset(1)
    'Find the last used column. (Assumes row one contains headers)
    'Commented this out to hard-code the last column.
    'lastCol = .Rows("1:1").Find("*", searchdirection:=xlPrevious).Column

    'Insert the new rows.
    r.EntireRow.Resize(vRows).Insert Shift:=xlDown

    'r needs to be reset since the new rows pushed it down.
    'This time we set r to be the first blank row that will be filled with formulas.
    Set r = .Range(.Cells(ActiveCell.Offset(1).Row, 1), _
             .Cells(ActiveCell.Offset(1).Row, "H")) '<~~ Replaced lastCol with "H"

    '**Add formulas to the new rows.**
    'Adds row two formulas to the first blank row.
    .Range(.Cells(2, 1), .Cells(2, "H")).Copy r
    'Adds row three formulas to the rest of the blank rows.
    .Range(.Cells(3, 1), .Cells(3, "H")).Copy r.Offset(1).Resize(vRows - 1)
End With

End Sub

修改

变量lastCol定义了从中复制公式的最右列。这个变量是使用第1行中的列标题设置的。我更喜欢使用这样的变量来使代码更加健壮（即，您可以在不破坏宏的情况下向数据集中添加列），但是，要实现这一点，您需要在每个上面使用标题使用过的列（或至少包含值的单元格）。

如果您不关心在未来添加更多列，您可以将最后一列硬编码到代码中（请参阅我的修订版）。

用于将特定的公式行复制到新创建的行的宏

1 个答案: