The following will insert three rows of footers :-
Sub InsertFooters()
Dim TargetWB As Workbook, AWB As String
Dim TotalPageBreaks As Long, pbIndex As Long, pbRow As Long, PreviousPageBreak As Long
Application.ScreenUpdating = False
AWB = ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:="C:\My Documents\" & AWB & " _ New.xls"
Set TargetWB = ActiveWorkbook
' insert footers
pbIndex = 0
PreviousPageBreak = 1
TotalPageBreaks = ActiveSheet.HPageBreaks.Count
While pbIndex < TotalPageBreaks
pbIndex = pbIndex + 1
pbRow = GetHPageBreakRow(pbIndex)
If pbRow > 0 Then
InsertFooter pbRow, PreviousPageBreak, True, ""
PreviousPageBreak = pbRow
TotalPageBreaks = ActiveSheet.HPageBreaks.Count
Else
pbRow = TotalPageBreaks
End If
Wend
' add the last footer
InsertFooter Range("A65536").End(xlUp).Row + 1, PreviousPageBreak, False, ""
Range("A1").Select
End Sub
Private Sub InsertFooter(RowIndex As Long, PreviousPageBreak As Long, InsertNewRows As Boolean, LabelText As String)
Const RowsToInsert As Long = 3
Dim i As Long, TargetRow As Long
TargetRow = RowIndex
If InsertNewRows Then
For i = 1 To RowsToInsert
Rows(RowIndex - RowsToInsert).Insert
Next i
TargetRow = RowIndex - RowsToInsert
End If
If PreviousPageBreak < 1 Then PreviousPageBreak = 1
' insert the required footer text :
Cells(TargetRow, 1).Formula = "Footer line 1 text here"
Cells(TargetRow + 1, 1).Formula = "Footer line 2 text here"
Cells(TargetRow + 2, 1).Formula = "Footer line 3 text here"
End Sub
Private Function GetHPageBreakRow(PageBreakIndex As Long) As Long
GetHPageBreakRow = 0
On Error Resume Next
ActiveWorkbook.Names("ASPB").Delete
On Error GoTo 0
ActiveWorkbook.Names.Add "ASPB", "=get.document(64)", False
Columns("A:A").Insert
Range("A1:A50").FormulaArray = "=transpose(aspb)"
On Error Resume Next
GetHPageBreakRow = Cells(PageBreakIndex, 1).Value
On Error GoTo 0
Columns("A").Delete
ActiveWorkbook.Names("ASPB").Delete
End Function