Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Signature lines in footer with "No Dupes"
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/ |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Excel - Golf - how to display "-2" as "2 Under" or "4"as "+4" or "4 Over" in a calculation cell | Excel Discussion (Misc queries) | |||
Signature missing when "send to" "mail recipient" | Excel Discussion (Misc queries) | |||
Count occurences of "1"/"0" (or"TRUE"/"FALSE") in a row w. conditions in the next | New Users to Excel | |||
Protect "signature" cell | Excel Worksheet Functions | |||
Print signature lines as footer | Excel Programming |