VBA for printing

mt

Board Regular
Joined
Feb 24, 2006
Messages
134
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

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
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
Hi,

1. could you please take care of only posting the relevant portion of code ?
2. are the blank pages all at the bottom of your spreadsheets ?

kind regards,
Erik
 

Forum statistics

Threads
1,137,300
Messages
5,680,699
Members
419,928
Latest member
dolincasting

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top