时间戳

首页 > 解决方案 > 如何在所选单元格下方添加空白行并保留上面的格式和公式

excel - 如何在所选单元格下方添加空白行并保留上面的格式和公式

问题描述

Sub addRows()
' Adds new blank lines based on user input, keeping formatting and formulas of above.

Dim numRows     As Long
Dim raSource    As Range
Dim bResult     As Boolean

Set raSource = ActiveCell.EntireRow
numRows = InputBox("Enter number of rows to insert. Rows will be added above the highlighted row.")
On Error Resume Next
raSource.Copy
bResult = Range(raSource.Offset(1, 0), raSource.Offset(numRows, 
     0)).EntireRow.Insert(Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove)
Application.CutCopyMode = False
If Not bResult Then
    MsgBox "Inserting rows failed!", vbExclamation
End If
End Sub

该代码按我的要求工作，除了它保留所选行中的所有数据并将其粘贴到新行。我只想保留所选行的格式和公式，并在下面插入新行。

标签： excelvba

解决方案

Try this code. I have linkedan example workbook as well. Let me know if this works. Download example workbook here

Sub insertXRows()

 Dim cell As Range
 Dim lngRows As Long
 Application.ScreenUpdating = False

'ERROR HANDLER
 On Error GoTo ErrMsg   

'#CHECK IF ACTIVE CELL IS IN A TABLE
'SOURCE: https://stackoverflow.com/a/34077874/10807836
 Dim r As Range
 Dim lo As ListObject

 Set r = ActiveCell
 Set lo = r.ListObject

 If Not lo Is Nothing Then
     Select Case lo.Name
         Case "Table1"
             If r.Row = lo.Range.Row Then
                 MsgBox "In Table1 Header"
             Else
                 MsgBox "In Table1 Body"
             End If
         Case "SomeOtherTable"
             '...
     End Select
 Else
     MsgBox "Active cell is not in any table. Please select a cell in an active table and retry."
     Exit Sub
 End If

'MSGBOX to enter #rows to insert
  lngRows = InputBox("Enter number of rows to insert. Rows will be added above the highlighted row.")

'CODE TO INSERT X Rows
  Selection.Resize(lngRows).EntireRow.Insert
     For Each cell In Intersect(ActiveSheet.UsedRange, Selection.Offset(-1, 0).EntireRow)
         If cell.HasFormula Then
             cell.Copy cell.Offset(1, 0)
         End If
     Next

 Application.ScreenUpdating = True


'ERROR MSG
  On Error GoTo 0
  Exit Sub
  ErrMsg: MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure insertX, line " & Erl & "."

End Sub

推荐阅读