Как вставить новую строку в диапазон и скопировать формулы

Question

У меня есть именованный диапазон, подобный следующему покрытию A2: D3

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

Я должен вставить новую строку, используя VBA, в диапазон, копируя формулы, а не значения.

Любые советы / ссылки с благодарностью.

Answer 1

Это должно сделать это:

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

Answer 2

Если вы начнете записывать макрос и фактически выполняете задачу в руке, он сгенерирует код для вас. Закончив запись, прекратите запись макроса, и у вас будет необходимый код, который вы сможете изменить.

Answer 3

В этом ответе рассматриваются следующие 3 проблемы с принятым в настоящее время ответом от @marg, первоначально опубликованным 13 апреля 2010 года в 9:43.

1. target.Rows(rowNr + 1).Insert: 1.1. не расширяет именованный диапазон на одну строку (AFAIK единственный способ сделать это неявно с помощью вставки строки (вместо явного изменения определения диапазона) и сделать это после указанной строки № с помощью строки 1 считать - 1) и 1.2) только смещает столбцы в диапазоне target вниз на одну строку. Во многих (и, вероятно, в большинстве) случаях столбцы справа и / или слева от диапазона target также должны быть смещены вниз.

2. target.Rows(rowNr).Copy target.Rows(rowNr + 1) не копирует Форматы, которые часто, если не всегда желательны, также.

Закрытая вложенная вкладкаNewRowInRange (_ TargetRange As Range, _ Необязательный InsertAfterRowNumber As Integer = -1, _ Необязательный 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

Answer 4

Мне нужно было развернуть решение, которое работало бы так же, как запрос на подключение к данным расширяет диапазон результатов с возможностью автоматического заполнения формул справа. Может быть, два года опоздал на награду, но я в любом случае рад поделиться!

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

Answer 5

Это должно помочь вам: http://www.mvps.org/dmcritchie/excel/insrtrow.htm

Answer 6

Вот еще одно решение, основанное на ответе @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