如何在選定單元格下方添加空白行並保留上面的格式和公式

Question

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

該代碼按我的要求工作，除了它保留所選行中的所有數據並將其粘貼到新行。 我只想保留所選行的格式和公式，並在下面插入新行。

Answer 1

試試這個代碼。 我也鏈接了一個示例工作簿。 讓我知道這個是否奏效。 在此處下載示例工作簿

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