Hi ng
Using xl 2003

Would like to print some signature lines in right footer of report
Tried setting up using beforeprint. Did not work.

Print procedure uses "No Dupes" printing procedure. Code below
Tried modifying "No Dupes" to establish right footer. Couldn't get i
to work

NoDupes:
Auofilters unique values in colA and prints report of like values.
Stops, prints new report of second group of like values. Continues i
this fashion until no more unique values

Sinature lines:
tab: mytools!
range A11:F16
Tried using borders for lines, didn't seem to work.
Now using underscore char's

TIA
-goss

Sub PrintTimeSheets()
'================================================= ===
'Copied from "NoDupes"
'Created with tons of help from:
' -John Walkenbach
' -Tom Ogilvy
' -Dave Paterson
'See "No dupes" on microsoft.public.excel.programming
'================================================= ===

Call Check_for_Error
Application.ScreenUpdating = False
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item
Dim allcells1 As Range
Dim bProc As Boolean

Sheets("Time_Entry").Select


' ========================================
' ========================================
' Added 8/20/04
' Print signature lines on each timesheet
' Copied from William - Excel forum
If Not ActiveSheet.Name = "Time_Entry" Then Exit Sub
Dim r As Range, s As String, c As Range, x As Integer
With Sheets("mytools")
Set r = .Range("A11:F16")
For x = 1 To 6
For Each c In r.Offset(x, 0)
s = s & " " & c
Next c
s = s & vbNewLine
Next x
End With
Sheets("Time_Entry").PageSetup.RightFooter = s

' The items Start in A2
Set AllCells = Range(Cells(2, 1), _
Cells(Rows.Count, 1).End(xlUp))

' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
' ================================================== ========
' Added 10/30/02
For Each Cell In AllCells
bProc = True
If IsNumeric(Cell.Value) Then
If Cell.Value = 0 Then bProc = False
End If
If bProc Then
NoDupes.Add Cell.Value, CStr(Cell.Value)
End If
' Note: the 2nd argument (key) for the Add method must be
string
Next Cell
' ================================================== ========
' ================================================== ========
' Old code
' For Each Cell In AllCells
' NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be
string
' Next Cell
' ================================================== ========
' ================================================== ========


' Resume normal error handling
On Error GoTo 0

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, befo=j
NoDupes.Add Swap2, befo=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

Set allcells1 = AllCells.Offset(-1, 0). _
Resize(AllCells.Count + 1, 10)
If ActiveSheet.AutoFilterMode = False Then
allcells1.AutoFilter
End If

For i = 1 To NoDupes.Count
AllCells.AutoFilter Field:=1, Criteria1:=NoDupes(i)
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&D"
.CenterFooter = "&P"
.RightFooter
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
' .PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = True
.Zoom = 65
' .PrintErrors = xlPrintErrorsDisplayed

allcells1.PrintOut
End With
Next


ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub


---
Message posted from http://www.ExcelForum.com/