I am having trouble controlling the printing of this report, so that it will not print blank pages as it loops through each item. Where the loop results in a blank page, I want to skip to the next Ce in the loop. I tried to control it by adding an If Lastrow >2 then, but it does not seem to control the printing. Any ideas how I can restrict the printing of blank pages? (The header is in Row 1).
Thanks,
Mike
Thanks,
Mike
Code:
Sub SubContSched_Rpt()
'----------------------------------------------------------------------------------------------------------------------
'Declarations
'---------------------------------------------------------------------------------------------------------------------
Dim i As Integer
Dim rngA As Range
Dim rngH As Range
Dim rngCopy As Range
Dim rngR As Range
Dim LastRow As Long
'--------------------------------------------------------------------------------------------------------------------------
'Set Excel to run fast
'-----------------------------------------------------------------------------------------------------------------------
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'------------------------------------------------------------------------------------------------------------------------
'Routine- Filter each Data Report by the Headers in Summary Sheet, Return the Lots, that match the date range
'-----------------------------------------------------------------------------------------------------------------------
Set outsh = Sheets("FilterCriteria")
Set ToSh = Worksheets("Report1")
ToRow = Worksheets("Report1").Range("A65536").End(xlUp).Row
With Worksheets("Data1")
Set rngA = .Range("A4")
Set rngCopy = Union(rngA, rngA.Offset(, 2))
Set rngCopy = Union(rngCopy, rngA.Offset(, 4).Resize(, 2))
Set rngCopy = Union(rngCopy, rngA.Offset(, 9))
Set rngCopy = Union(rngCopy, rngA.Offset(, 11).Resize(, 2))
Set rngCopy = Union(rngCopy, rngA.Offset(, 34))
rngCopy.Copy
Worksheets("Report1").Range("A" & ToRow).PasteSpecial Paste:=xlPasteValues
End With
'-----------------------------------------------------------------------------------
'Set Filter in Place
'For Each ce In outsh.Range (Cells(3,66),Cells(outsh.cells(65536,66).End(xlUp))
'For Each ce In outsh.Range("BN3", outsh.Cells(Rows.Count), 66).End(xlUp))
Set outsh = Worksheets("FilterCriteria")
For Each Ce In outsh.Range("BN12", "BN13") 'range is hardcoded BN3 to BN58
For i = 1 To 10
ToRow = Worksheets("Report1").Range("A65536").End(xlUp).Row + 1
With Worksheets("Data" & i)
LastRow = .Range("A65536").End(xlUp).Row
'On Error Resume Next
If LastRow > 4 Then
.Range("AO1").Value = "Resource" 'Criteria Range copied into Data sheets
.Range("AO2").Value = Ce.Value
.Range("AP1").Value = "Date"
.Range("AQ1").Value = "Date"
.Range("AP2").Value = Worksheets("FilterCriteria").Cells(3, 3)
.Range("AQ2").Value = Worksheets("FilterCriteria").Cells(3, 4)
.Range("A4:AN" & LastRow).AdvancedFilter Action:=xlFilterInPlace, criteriarange:=.Range("AO1:AQ2") ', copytorange:=outsh.Cells(Rows.Count, ce.Column).End(xlUp).Offset(1, 0)
.Range("AO1:AQ2").ClearContents
End If
End With
Next i
Copy_Rng 'Procedure below
Sort_Report1 'Procedure below
FormatReport 'Procedure below
Report1PageSetUp 'Procedure below
Worksheets("Report1").PrintOut Copies:=1, Collate:=True
Clear_Report1 'Procedure below
Next Ce
Worksheets("Report1").Clear
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = xlCalculationManual
End With
End Sub
'---------------------------------------------------------------------------------------------
Sub Copy_Rng() 'After Filter is complete on loop, copy each Data sheet to Report1
'Set Columns to copy
For i = 1 To 10 ' Set i counter to the number of Data Sheets in Workbook
ToRow = Worksheets("Report1").Range("A65536").End(xlUp).Row + 1 ' ToRow resets to new row after each loop
With Worksheets("Data" & i)
'On Error Resume Next
'LastRow = .Range(Cells("A4"), Cells("A"&Rows.count)).End(xlUp).Row
LastRow = .Range("A65536").End(xlUp).Row
If LastRow > 4 Then
Set rngA = Worksheets("Data" & i).Range("A5:A" & LastRow)
Set rngCopy = Union(rngA, rngA.Offset(, 2)) 'Starts & Lots
Set rngCopy = Union(rngCopy, rngA.Offset(, 4).Resize(, 2)) 'Plan & Manager
Set rngCopy = Union(rngCopy, rngA.Offset(, 9)) 'Resource
Set rngCopy = Union(rngCopy, rngA.Offset(, 11).Resize(, 2)) 'Task & Date
rngCopy.Copy
Worksheets("Report1").Range("A" & ToRow).PasteSpecial Paste:=xlPasteValues
Worksheets("Data" & i).ShowAllData
End If
End With
Next i
End Sub
'---------------------------------------------------------------------------------------------------------------------------
'Routine-Sort Report
'----------------------------------------------------------------------------------------------------------------------------
Sub Sort_Report1()
With Worksheets("Report1")
If LastRow > 1 Then
LastRow = Range("A" & Rows.Count).End(xlUp).Row 'Finds last data row
NumCol = Cells(1, 255).End(xlToLeft).Column 'Start at Row 1 to find last col
'Sort Key: Date,Task Code
.Range(Cells(1, 1), Cells(LastRow, NumCol)).Sort Key1:=Range("G1"), Order1:=xlAscending, Key2:=Range("H1"), Order2:=xlAscending, Key3:=Range("B1"), Order1:=xlAscending, Header:=xlYes
End If
End With
End Sub
'-----------------------------------------------------------------------------------------------------------------------
' Format report
'-----------------------------------------------------------------------------------------------------------------
Sub FormatReport()
LastRow = Cells(65536, 1).End(xlUp).Row
LastCol = Cells(1, 255).End(xlToLeft).Column
With Worksheets("Report1").Range("A1").EntireRow 'Format Headers
.Font.Bold = True
.HorizontalAlignment = xlLeft
.WrapText = True
End With
With Worksheets("Report1") 'Set Column widths
.Range("A1").ColumnWidth = 5
.Range("B1").ColumnWidth = 5
.Range("C1").ColumnWidth = 5
.Range("D1").ColumnWidth = 10
.Range("E1").ColumnWidth = 20
.Range("F1").ColumnWidth = 30
.Range("G1").ColumnWidth = 20
.Range("H1").ColumnWidth = 5
.Range("G2:G" & LastRow).NumberFormat = "[$-409]ddd, d-mmm" 'Format Date
End With
End Sub
'-----------------------------------------------------------------------------------------------------------------
'Routine-Set Print Page Set up
'-------------------------------------------------------------------------------------------------------------------
Sub Report1PageSetUp()
With Worksheets("Report1")
LastRow = Range("A65536").End(xlUp).Row
LastCol = Range("IV4").End(xlToLeft).Column
If LastRow > 1 Then
Worksheets("Report1").PageSetup.PrintArea = Range(Cells(1, 1), Cells(LastRow, 8)).Address
With Worksheets("Report1").PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
.LeftHeader = "&D"
.CenterHeader = "Botanica Lakes" & Chr(10) & "Subcontractor Schedule"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = "Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 90
.PrintErrors = xlPrintErrorsDisplayed
End With
End If
End With
End Sub
