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

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

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

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

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

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

2. target.Rows(rowNr).Copy target.Rows(rowNr + 1) не копирует Форматы, которые часто обычно не требуются.

Private Sub InsertNewRowInRange (_ TargetRange Как 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 6

Вот еще одно здание решение на ответ от @Том. Он не использует «Selection», и можно вставить несколько строк.

' 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