vba 如何在区域中插入新行并复制公式

How to insert a new row into a range and copy formulas

提问by Samuel G

I have a named range like the following covering A2:D3

我有一个命名范围，如下所示，涵盖 A2:D3

ITEM    PRICE   QTY SUBTOTAL
1           10  3   30
1           5   2   10
           TOTAL:   40

I am to insert a new row using VBA into the range copying the formulas not values.

我将使用 VBA 在复制公式而不是值的范围中插入一个新行。

Any tips/links greatly appreciated.

非常感谢任何提示/链接。

回答by marg

This should do it:

这应该这样做：

Private Sub newRow(Optional line As Integer = -1)
Dim target As Range
Dim cell As Range
Dim rowNr As Integer

    Set target = Range("A2:D3")

    If line <> -1 Then
        rowNr = line
    Else
        rowNr = target.Rows.Count
    End If

    target.Rows(rowNr + 1).Insert
    target.Rows(rowNr).Copy target.Rows(rowNr + 1)
    For Each cell In target.Rows(rowNr + 1).Cells
        If Left(cell.Formula, 1) <> "=" Then cell.Clear
    Next cell
End Sub

回答by Neil Knight

If you start recording a macro and actually do the task in hand, it will generate the code for you. Once finished, stop recording the macro and you'll have the code needed which you can then amend.

如果您开始录制宏并实际完成手头的任务，它将为您生成代码。完成后，停止录制宏，您将拥有所需的代码，然后您可以对其进行修改。

回答by user183037

This should help you: http://www.mvps.org/dmcritchie/excel/insrtrow.htm

这应该对您有所帮助：http: //www.mvps.org/dmcritchie/excel/insrtrow.htm

回答by user183037

I needed to roll a solution that worked like the way a data connection query expands a result-range with optionally autofilling formulas off to the right. Perhaps two years late for the bounty, but I'm happy to share anyway!

我需要推出一个解决方案，其工作方式类似于数据连接查询扩展结果范围，并可选择将自动填充公式向右关闭。也许赏金晚了两年，但无论如何我很乐意分享！

Public Sub RangeExpand(rangeToExpand As Range, expandAfterLine As Integer, Optional linesToInsert As Integer = 1, Optional stuffOnTheRight As Boolean = False)
    Debug.Assert rangeToExpand.Rows.Count > 1
    Debug.Assert expandAfterLine < rangeToExpand.Rows.Count
    Debug.Assert expandAfterLine > 0

    If linesToInsert = 0 Then Exit Sub
    Debug.Assert linesToInsert > 0

    Do
        rangeToExpand.EntireRow(expandAfterLine + 1).Insert
        linesToInsert = linesToInsert - 1
    Loop Until linesToInsert <= 0

    If stuffOnTheRight Then
        rangeToExpand.Item(expandAfterLine, rangeToExpand.Columns.Count + 1).Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(rangeToExpand.Item(expandAfterLine, 1), Selection).Select
    Else
        Range(rangeToExpand.Item(expandAfterLine, 1), rangeToExpand.Item(expandAfterLine, rangeToExpand.Columns.Count)).Select
    End If
    Selection.AutoFill Destination:=Range(rangeToExpand.Item(expandAfterLine, 1), rangeToExpand.Item(rangeToExpand.Rows.Count, Selection.Columns.Count))
End Sub

回答by Tom

This Answer addresses the following 3 issues with the currently Accepted Answer from @marg originally posted Apr 13 '10 at 9:43.

此答案解决了@marg 最初于 2010 年 4 月 13 日 9:43 发布的当前已接受答案的以下 3 个问题。

1. target.Rows(rowNr + 1).Insert: 1.1. does not extend the Named Range by one Row (AFAIK the only way to do so implicitly via Insert Row (vs. explicitly modifying Range definition) and to do so afterspecified Row # is via Row #'s 1 to Count - 1) and 1.2) only shifts Columns in the targetRange down by one Row. In many (and probably most) cases, Columns to the right and/or left of the targetRange need to be shifted down as well.

2. target.Rows(rowNr).Copy target.Rows(rowNr + 1)does not copy the Formats which are often if not usually desired also.

1. target.Rows(rowNr + 1).Insert： 1.1。不会将命名范围扩展一行（AFAIK 是通过插入行（与显式修改范围定义）隐式这样做的唯一方法，并且在指定行 #之后这样做是通过行 # 的 1 到 Count - 1）和1.2) 仅将target范围中的列向下移动一行。在许多（可能是大多数）情况下，target范围右侧和/或左侧的列也需要下移。

2. target.Rows(rowNr).Copy target.Rows(rowNr + 1)不复制通常不需要的格式。

Private Sub InsertNewRowInRange( _ TargetRange As Range, _ Optional InsertAfterRowNumber As Integer = -1, _ Optional InsertEntireSheetRow As Boolean = True)

Private Sub InsertNewRowInRange( _ TargetRange As Range, _ Optional InsertAfterRowNumber As Integer = -1, _ Optional InsertEntireSheetRow As Boolean = True)

' -- InsertAfterRowNumber must be 1 to TargetRange.Rows.Count - 1 for TargetRange to be extended by one Row and for there to be
' --    Formats and Formulas to copy from (e.g. can't be 0).  Default: If -1, defaults to TargetRange.Rows.Count.
' --    Recommend dummy spacer Row at the bottom of TargetRange which, btw, would also be necessary to manually extend a Range
' --    by one Row implicitly via Insert Row (vs. explicilty via changing Range definition).

        If InsertAfterRowNumber = -1 Then
            InsertAfterRowNumber = TargetRange.Rows.Count
        End If

        If InsertEntireSheetRow Then
            TargetRange.Cells(InsertAfterRowNumber + 1, 1).Select
            Selection.EntireRow.Insert
        Else
            TargetRange.Rows(InsertAfterRowNumber + 1).Insert
        End If

        TargetRange.Rows(InsertAfterRowNumber).Select
        Selection.Copy

        TargetRange.Rows(InsertAfterRowNumber + 1).Select
        Selection.PasteSpecial _
            Paste:=xlPasteFormats, _
            Operation:=xlNone, _
            SkipBlanks:=False, _
            Transpose:=False
        Selection.PasteSpecial _
            Paste:=xlPasteFormulas, _
            Operation:=xlNone, _
            SkipBlanks:=False, _
            Transpose:=False

        Application.CutCopyMode = False

    End Sub

回答by tomashm

Here's another solution building on answer from @Tom. It does not use "Selection", and it's possible to insert multiple rows.

这是建立在@Tom 回答基础上的另一个解决方案。它不使用“选择”，并且可以插入多行。

' Appends one or more rows to a range.
' You can choose if you want to keep formulas and if you want to insert entire sheet rows.
Private Sub expand_range( _
                        target_range As Range, _
                        Optional num_rows As Integer = 1, _
                        Optional insert_entire_sheet_row As Boolean = False, _
                        Optional keep_formulas As Boolean = False _
                        )

    Application.ScreenUpdating = False
    On Error GoTo Cleanup

    Dim original_cell As Range: Set original_cell = ActiveCell
    Dim last_row As Range: Set last_row = target_range.Rows(target_range.Rows.Count)

    ' Insert new row(s) above the last row and copy contents from last row to the new one(s)
    IIf(insert_entire_sheet_row, last_row.Cells(1).EntireRow, last_row) _
        .Resize(num_rows).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
    last_row.Copy
    last_row.Offset(-num_rows).PasteSpecial
    last_row.ClearContents

    On Error Resume Next ' This will fail if there are no formulas and keep_formulas = True
        If keep_formulas Then
            With last_row.Offset(-num_rows).SpecialCells(xlCellTypeFormulas)
                .Copy
                .Offset(1).Resize(num_rows).PasteSpecial
            End With
        End If
    On Error GoTo Cleanup

Cleanup:
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    original_cell.Select
    If Err Then Err.Raise Err.Number, , Err.Description
End Sub