Inserting a Range into Footer

[Ornithopter]

Wondering if anyone at this forum can
add to the thread I have running here:
http://www.mrexcel.com/board2/viewtopic.php?t=95505

[Jacob Hilderbrand]

Ornithopter:

I'm wondering if there is any way to insert a Range of cells into the
footer. The effect I'm looking for is the same as if you were to go
to 'Page Setup'>Sheet>'Rows to Repeat at Top' except I want
'Rows to Repeat at Bottom'.

I have tried the following with no luck:

Private Sub Workbook_BeforePrint(Cancel As Boolean) 
With ActiveSheet.PageSetup 
.LeftFooter = Range("B237:M239").Text 
End With 
End Sub 

Where the range "B237:M239" contains the information

and formatting that I would like at the bottom of every
page.

Any ideas?

Ornithopter:

If someone believes this is not possible,
that information would also be helpful.

Damon Ostrander:

Hi Ornithopter,

Your approach is correct and should work, but you cannot assign the text of a range of multiple cells to a single text string--you must do it one cell at a time, like this:

.LeftFooter = [B237].Text & [C237].Text & ... & [M239].Text

This basically concatenates all the cell text to produce the desired string.

This may not completely produce the desired result, though, if you are expecting a carriage return and linefeed between the text contained in different rows of cells. In order to add line feeds you must concatenate vbLF (or perhaps vbCrLf) into the string where you want the new line to occur.
_________________
Keep Excelling.

Damon

Ornithopter:

Hmmm....

Thanks Damon.

It is unfortunate that there is no way to maintian
the formatting of the cells as they have borders
and pictures that I would like to include at the
bottom of every page.

I guess that it would be best to import the
printable area into Word and do it from there?

Ornithopter:

Another Solution I just thought of (to stay in excel)
would be to have 2 sheets:
one with data, the other with the footer.

Then write a macro that:
1) Calculates how many rows fit on
the current page settings.

2) Calculates how many rows the footer
range requires.

3) Removes all 'Old' footers (if I ran the
macro before)

4) Inserts a copy of the footer at regular
calculated intervals so that it appears
at the bottom of every page and gives
the effect I want.

Thoughts?

[Ornithopter]

BUMP...

[Anne Troy]

I'm pretty much thinking that if Damon and DRJ didn't come up with anything, you're pretty much SOL. However....have you considered printing it from Word, which has normal headers and footers?

You could link your data via a mail merge...

[mvidas]

Hi Ornithopter,

I should be able to get something together for you to accomplish this, but I'm not sure how long I can devote today to this. I can tell you that this will be my only side project for the day

I'll let you know!
Matt

[Ornithopter]

Dreamboat :
Yah I thought about the word option... it's still a possibility.
I am trying to keep it in Excel because the people at work
prefer it and get scared if they have to use more then one
app at the same time

Mvidas:
What is the plan of attack with your idea?
If you're short on time, just explain what you're thinking, I could
give it a try (I hate using up other peoples time when, technically,
I'm paid to do this). I will post my findings (successful or not).

[TonyJollans]

Hi Ornithopter,

If you want to use Word it should be possible to do it behind the scenes so that the Users don't know anything about it - they just press a button and it prints. If Matt doesn't get you sorted I don't mind having a play with it. Is your print likely to be more than one page wide? For that matter is your footer likely to be more than one page wide??

[mvidas]

It's not a problem, I actually just had 20 minutes while waiting for data from a co-worker, so I just got this done.

While the code is commented, I'll briefly explain what it does before I post it.
-Copies the sheet into a new one, placed before the active worksheet
-Figures out the height of the 'footer' cells
-Loops through each page, figures out where to insert the footer range, then copies the range to the bottom of that page

This works for me in Excel 2000, if you have a different version or are just experiencing any issues, let me know what they are and I'll work through them to get it working for you. If you want to use this macro each time the sheet is to be printed, un-comment the last 4 lines in the sub

Sub RowsToRepeatAtBottomOfPrintedPage()
'http://www.vbaexpress.com/forum/showthread.php?t=426
 Dim hNum As Long, h As Long, x As Long, Ftr As Range, FtrH As Double, FtrHt As Double, nM As String
 nM = Mid(ActiveSheet.Name, 1, 21) 'First 21 characters of sheet name
 ActiveSheet.Copy before:=Sheets(ActiveSheet.Index) 'Copy current sheet and place it before active sheet
 ActiveSheet.Name = "Printable " & nM 'Rename new sheet to be "Printable " and first 21 characters of original name
 Set Ftr = Rows("237:239") 'Set Footer range / Rows to repeat at the bottom of the page
 FtrH = Ftr.Height 'Set height of footer
 Range("A1").SpecialCells(xlLastCell).Select 'Select last cell in sheet, necessary while using hpagebreaks for some reason
 h = 1 'Horizontal page break counter
 Do
  FtrHt = FtrH 'Set temp footer height variable to equal footer height
  hNum = ActiveSheet.HPageBreaks(h).Location.Row 'Set row variable to page break row number
  For x = 1 To ActiveSheet.UsedRange.Rows.Count 'Loop through rows to calculate height (to see where to put footer)
    FtrHt = FtrHt - Rows(hNum - x).Height 'Subtract row from temp footer height
    If FtrHt <= 0 Then Exit For 'Once enough rows have been looped through to make room for footer, exit loop
Next x 'Next row
  Ftr.Copy 'Copy footer range
  Rows(hNum - x).Insert shift:=xlDown 'Insert footer range at end of sheet
  Application.CutCopyMode = False 'Clear clipboard
  h = h + 1 'Next H pagebreak counter
 Loop Until h > ActiveSheet.HPageBreaks.Count 'Loop to next page, unless already on last page
 Range("A1").Select 'Select first cell again
'Uncomment the following lines if this will be used each time the page is printed
 'ActiveSheet.PrintOut
 'Application.DisplayAlerts = False
 'ActiveSheet.Delete
 'Application.DisplayAlerts = True
End Sub

[tommy bak]

Ornithopter , which version of excel are you using ?
In XP it's possible to insert a minor picture in the footer.
So my suggestion would be that you lookup a code to convert and save your range to a picture (I know it's out there, I've seen it), and load it into the footer with

ActiveSheet.PageSetup.LeftFooterPicture.Filename = "D:\range2.gif"

[Zack Barresse]

...(I know it's out there, I've seen it)...

http://xcelfiles.homestead.com/VB_Quick17.html

Courtesy of Mr. Ivan Moala.

[mvidas]

The code to copy a range as a picture in excel would be

Range("B237:M239").CopyPicture

But VBA doesn't have SavePicture or a similar method available, so you'd have to copy the range as a picture, go to Paint (or similar program), paste it and save it, then you can reference the picture that way.

You can also copy the range as a picture by selecting the range, holding down SHIFT, clicking Edit, then selecting copy picture (only available by holding down Shift while clicking edit (or shift-alt-E))

[mvidas]

Cool

[tommy bak]

Thanks Firefytr
I knew it was somewhere. I've been searching for Harald Staff. I'm sure he hs made one too, just could't find it :-)
Tommy Bak

[Zack Barresse]

Np Tommy. I was actually just toying with that code a couple of weeks ago, so it was still fresh in the ol' noggin.

[Ornithopter]

Thank you everyone for you amazing input!!!
That kewl how you can copy a range as a picture!
I wonder why MS never thought of letting you save/paste
that information somewhere in your excel spreadsheet?

Mvidas:
Thanks a million for the code, I'll try it in a few mins ;-)

PS
I'm also running excel 2000

Muahaha... now that I have everyone's create juices flowing,
I will try to find out what use CopyPicture is supposed to have...

[mvidas]

The only times I've ever used copypicture is when I am putting a chart into powerpoint and don't want to have an actual chart in the presentation. Other than that, I've never used it
Matt

[Ornithopter]

Mvidas:

I tried your script and it works beautifully except that
it doesn't put a footer on the last page. I have modified
your script to include the ability to do this.

I also made a modification to accept a selected range
as the rows to insert as the footer. You would need
to make a non-modal form that prompts the user to
select a range for the footer (my solution) or simply
put some error checking in to make sure there is a
range selected. Also, I refactored the code so that
it's easier for me to understand (sorry I'm a java
programmer and I can't stand one-letter variable names)


And here we go:

Option Explicit
 Private footerRange As Range
 
 Sub RowsToRepeatAtBottomOfPrintedPage()
     'http://www.vbaexpress.com/forum/showthread.php?t=426
     Dim footerHeight As Double
     Dim activeSheetName As String
'Set Footer range / Rows to repeat at the bottom of the page
     Dim aRange As String
     aRange = Selection.Row & ":" & Selection.Row + Selection.Rows.Count - 1
     Set footerRange = Rows(aRange)
'First 21 characters of sheet name
     activeSheetName = Mid(ActiveSheet.Name, 1, 21)
'Copy current sheet and place it before active sheet
     ActiveSheet.Copy after:=Sheets(ActiveSheet.Index)
'Remove the Footer Rows from the Copy
     ActiveSheet.Rows(aRange).Delete Shift:=xlShiftUp
'Rename new sheet to be "Printable " and first 21 characters of original name
     ActiveSheet.Name = "Printable " & activeSheetName
'Set height of footer
     footerHeight = footerRange.Height
'Select last cell in sheet, necessary while using hpagebreaks for some reason
     Range("A1").SpecialCells(xlLastCell).Select
'Horizontal page break counter
     Dim pageBreakCounter As Long
     pageBreakCounter = 1
'Loop through enough times to put a footer
     'On every page (the number of pages changes
     'as the macro runs.
     Do
         Call addFooterAt(pageBreakCounter, footerHeight)
'Next pagebreak counter
         pageBreakCounter = pageBreakCounter + 1
     Loop Until pageBreakCounter > ActiveSheet.HPageBreaks.Count 'Loop to next page, unless already on last page
'Hack to add footer to bottom of last page
     'Create a cell with a space in it and
     'insert rows before it until you have a new
     'page.  Then insert your footer the same way
     'as above and remove the cell with the space
     'so as not to print an extra blank page
     Dim lastRow As Integer
     lastRow = ActiveSheet.UsedRange.Rows.Count + 1
'Put a space in the cell 2 cells down from the
     'last cell
     ActiveSheet.Cells(lastRow + 1, 1) = " "
'Keep adding blank rows
     While pageBreakCounter > ActiveSheet.HPageBreaks.Count
         ActiveSheet.Rows(lastRow).Insert Shift:=xlDown
     Wend
'Insert Last Footer
     Call addFooterAt(ActiveSheet.HPageBreaks.Count, footerHeight)
'Remove the spaced out cell ;-)
     ActiveSheet.Rows(ActiveSheet.UsedRange.Rows.Count).Delete Shift:=xlShiftUp
'Select first cell again
     Range("A1").Select
'Uncomment the following lines if this will be used each time the page is printed
      'ActiveSheet.PrintOut
      'Application.DisplayAlerts = False
      'ActiveSheet.Delete
      'Application.DisplayAlerts = True
 End Sub
 
 Private Sub addFooterAt(page As Long, footerHeight As Double)
     Dim rowOfPageBreak As Long
     Dim tempHeight As Double
     Dim RowHeight As Double
     Dim x As Long
'Set temp footer height variable to equal footer height
     tempHeight = footerHeight
'Set row variable to page break row number
     rowOfPageBreak = ActiveSheet.HPageBreaks(page).Location.Row
'For each given page, start at the last row in
     'the page and start moving upwards.  For each row of
     'the rows encountered while moving backwards, subtract
     'that rows height from the tempHeight of the footer.
     'When the temp height is less than or equal to zero,
     'we have moved up far enough so that if we insert the
     'footer in the current location, it will appear in its
     'entirety at the bottom of the page.
     For x = 1 To ActiveSheet.UsedRange.Rows.Count
         'Subtract row from temp footer height
         RowHeight = Rows(rowOfPageBreak - x).Height
         tempHeight = tempHeight - RowHeight 'Rows(rowOfPageBreak - x).Height
'Once enough rows have been looped through to make room for footer, exit loop
         If tempHeight <= 0 Then Exit For
     Next x 'Next row
'Copy footer range
     footerRange.Copy
'Insert footer range at end of sheet
     Rows(rowOfPageBreak - x).Insert Shift:=xlDown
'Clear clipboard
     Application.CutCopyMode = False
 End Sub

[mvidas]

Looks good! If you want to be able to select the footer range at runtime, use the following code:

'Set Footer range / Rows to repeat at the bottom of the page
On Error Resume Next
Set footerRange = Application.InputBox(prompt:="Select range of cells to " & _
 "include at the bottom of each page", Title:="Select Footer Rows", Type:=8).EntireRow
If footerRange Is Nothing Then msgbox "No selection detected": Exit Sub
On Error GoTo 0

Matt