Row insertion - lost forumlas

[sgrech]

I have a spreadsheet which shows date in numerous cells in column B. In
column A there is an IF forumla which calculates the number of days
between the date(s) in column B and todays date (stored in C1).

My problem is that when I have need to insert a row (which is necessary
sometimes) the inserted row no longer shows the formula in column A of
that row. Is there any way that I could insert a row and somehow keep
the forumula?

Any suggestions would be gratefully received.

Cheers
Simon

 

[Trevor Shuttleworth]

Simon

the following routines were written to add a row above or below the "active"
row, copy any formulae and formats and add some borders and fonts, etc. May
not be exactly what you want but they should set you off in the right
direction:

Option Explicit
Option Private Module

' ===== ===== ===== ===== ===== ===== ===== ===== ===== =====
Sub InsertAbove()
' ===== ===== ===== ===== ===== ===== ===== ===== ===== =====

Dim BaseCell As Range
Dim BaseRange As Range
Dim BaseRow As Long
Dim FirstCell As Long
Dim LastCell As Long
Dim c As Range

Set BaseCell = ActiveCell
BaseRow = BaseCell.Row
LastCell = Cells(1, Columns.Count).End(xlToLeft).Column

Set BaseRange = Range(Cells(BaseRow, 1), Cells(BaseRow, LastCell))

Application.ScreenUpdating = False

BaseCell.EntireRow.Insert

For Each c In BaseRange
If c.HasFormula Then
c.Offset(-1, 0).FormulaR1C1 = c.FormulaR1C1
c.Copy
c.Offset(-1, 0).PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
End If
Next 'c

Cells(BaseRow, 1).Select

With BaseRange.Offset(-1, 0)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
.Font.Name = "Arial"
.Font.Size = 8
End With

Application.ScreenUpdating = True

End Sub

' ===== ===== ===== ===== ===== ===== ===== ===== ===== ===== Sub
InsertBelow()
' ===== ===== ===== ===== ===== ===== ===== ===== ===== =====

Dim BaseCell As Range
Dim BaseRange As Range
Dim BaseRow As Long
Dim FirstCell As Long
Dim LastCell As Long
Dim c As Range

Set BaseCell = ActiveCell
BaseRow = BaseCell.Row
LastCell = Cells(1, Columns.Count).End(xlToLeft).Column

Set BaseRange = Range(Cells(BaseRow, 1), Cells(BaseRow, LastCell))

Application.ScreenUpdating = False

BaseCell.Offset(1, 0).EntireRow.Insert

For Each c In BaseRange
If c.HasFormula Then
c.Offset(1, 0).FormulaR1C1 = c.FormulaR1C1
c.Copy
c.Offset(1, 0).PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
End If
Next 'c

Cells(BaseRow, 1).Offset(1, 0).Select

With BaseRange.Offset(1, 0)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 0
.Font.Name = "Arial"
.Font.Size = 8
End With

Application.ScreenUpdating = True

End Sub

' ===== ===== ===== ===== ===== ===== ===== ===== ===== =====

Regards

Trevor