PDA

View Full Version : Solved: Inserting a Range into Footer



Ornithopter
07-05-2004, 05:19 PM
Wondering if anyone at this forum can
add to the thread I have running here:
http://www.mrexcel.com/board2/viewtopic.php?t=95505
(http://www.mrexcel.com/board2/viewtopic.php?p=462537#462537)

Jacob Hilderbrand
07-05-2004, 05:26 PM
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
07-06-2004, 08:17 AM
BUMP...

Anne Troy
07-06-2004, 09:06 AM
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
07-06-2004, 09:46 AM
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
07-06-2004, 10:20 AM
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 :D

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
07-06-2004, 10:51 AM
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
07-06-2004, 10:56 AM
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
07-06-2004, 11:22 AM
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
07-06-2004, 11:41 AM
...(I know it's out there, I've seen it)...


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

Courtesy of Mr. Ivan Moala. :)

mvidas
07-06-2004, 11:41 AM
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
07-06-2004, 11:43 AM
Cool :)

tommy bak
07-06-2004, 12:08 PM
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
07-06-2004, 12:18 PM
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
07-06-2004, 01:22 PM
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
07-06-2004, 03:38 PM
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
07-07-2004, 09:16 AM
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)
:rolleyes:

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
07-07-2004, 09:43 AM
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