Set Dynamic Print Range

K

km10

New Member
Joined
Sep 1, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
I'm trying to set a print range that varies for each sheet based the last row in column M having data. Right now I have each one set to M175, but some of the pages print out blank and I'd rather it just find the last column that has data and not have to delete pages. It's multiple sheets, but I just included two below. Any ideas on how to write this code?

VBA Code: 
Sub FHWAPrintPDF()
Dim myfhwa As Worksheet
Set myfhwa = ActiveSheet

With ActiveSheet.PageSetup
    .Orientation = xlPortrait
    .LeftMargin = Application.InchesToPoints(0.35)
    .RightMargin = Application.InchesToPoints(0.35)
    .TopMargin = Application.InchesToPoints(0.35)
    .BottomMargin = Application.InchesToPoints(0.5)
    .FitToPagesTall = False
    .FitToPagesWide = 1
    .LeftFooter = "&16 " & Range("B6")
    .CenterFooter = ""
    .RightFooter = "&16 " & Range("F6")
End With

    Sheets("27219").Activate
    ActiveSheet.Range("A1:M57" & "," & "A59:M175").Select
    ActiveSheet.PageSetup.Orientation = xlPortrait
    
    Sheets("27316").Activate
    ActiveSheet.Range("A1:M57" & "," & "A59:M175").Select
    ActiveSheet.PageSetup.Orientation = xlPortrait
    
    Sheets(Array("27219", "27316")).Select
    
    Selection.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=ThisWorkbook.Path & "/" & "ACDPW.FHWA.Report." & Format(Date, "DDMMMYYYY"), _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    OpenAfterPublish:=True, _
    IgnorePrintAreas:=False

ThisWorkbook.Sheets("Dashboard").Activate

End Sub
 
Sort by date Sort by votes
Ok see how you go with this. I made some other tweaks so ideally if you can replace what you had with this.

VBA Code: 
Sub SetPrintAreasEachSheet()

    Dim wb As Workbook
    Dim sht As Worksheet
    Dim rngPrn As Range
    Dim strPrnArea As String
    Dim lastRow As Long
    Dim arrPDFSheets() As Variant
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    Set wb = ThisWorkbook
    arrPDFSheets = Array("27219", "27316", "28426", "76388", "93371", "93394", "93915", "93917", "93419", "93922")
    
    For i = LBound(arrPDFSheets) To UBound(arrPDFSheets)
        Set sht = wb.Worksheets(arrPDFSheets(i))
        
        With sht
            lastRow = .Cells(Rows.Count, "M").End(xlUp).Row
            
            Set rngPrn = Union(.Range(.Cells(1, "A"), .Cells(57, "M")), _
                                    .Range(.Cells(59, "A"), .Cells(lastRow, "M")))
            strPrnArea = "='" & .Name & "'!" & rngPrn.Address
                 
            With .PageSetup
                .PrintArea = strPrnArea
                .Orientation = xlPortrait
                .LeftMargin = Application.InchesToPoints(0.35)
                .RightMargin = Application.InchesToPoints(0.35)
                .TopMargin = Application.InchesToPoints(0.35)
                .BottomMargin = Application.InchesToPoints(0.5)
                .FitToPagesTall = False
                .FitToPagesWide = 1
                .LeftFooter = "&16 " & sht.Range("B6")
                .CenterFooter = ""
                .RightFooter = "&16 " & sht.Range("F6")
            End With
            
        End With
    Next i
    
    wb.Worksheets(arrPDFSheets).Select
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "/" & "ACDPW.FHWA.Report." & Format(Date, "DDMMMYYYY"), _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        OpenAfterPublish:=True, _
        IgnorePrintAreas:=False

    ThisWorkbook.Sheets("Dashboard").Activate
    
    Application.ScreenUpdating = True

End Sub
 
Upvote 0

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Alex Blakenburg said:
Ok see how you go with this. I made some other tweaks so ideally if you can replace what you had with this.

VBA Code: 
Sub SetPrintAreasEachSheet()

    Dim wb As Workbook
    Dim sht As Worksheet
    Dim rngPrn As Range
    Dim strPrnArea As String
    Dim lastRow As Long
    Dim arrPDFSheets() As Variant
    Dim i As Long
   
    Application.ScreenUpdating = False
   
    Set wb = ThisWorkbook
    arrPDFSheets = Array("27219", "27316", "28426", "76388", "93371", "93394", "93915", "93917", "93419", "93922")
   
    For i = LBound(arrPDFSheets) To UBound(arrPDFSheets)
        Set sht = wb.Worksheets(arrPDFSheets(i))
       
        With sht
            lastRow = .Cells(Rows.Count, "M").End(xlUp).Row
           
            Set rngPrn = Union(.Range(.Cells(1, "A"), .Cells(57, "M")), _
                                    .Range(.Cells(59, "A"), .Cells(lastRow, "M")))
            strPrnArea = "='" & .Name & "'!" & rngPrn.Address
                
            With .PageSetup
                .PrintArea = strPrnArea
                .Orientation = xlPortrait
                .LeftMargin = Application.InchesToPoints(0.35)
                .RightMargin = Application.InchesToPoints(0.35)
                .TopMargin = Application.InchesToPoints(0.35)
                .BottomMargin = Application.InchesToPoints(0.5)
                .FitToPagesTall = False
                .FitToPagesWide = 1
                .LeftFooter = "&16 " & sht.Range("B6")
                .CenterFooter = ""
                .RightFooter = "&16 " & sht.Range("F6")
            End With
           
        End With
    Next i
   
    wb.Worksheets(arrPDFSheets).Select
   
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "/" & "ACDPW.FHWA.Report." & Format(Date, "DDMMMYYYY"), _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        OpenAfterPublish:=True, _
        IgnorePrintAreas:=False

    ThisWorkbook.Sheets("Dashboard").Activate
   
    Application.ScreenUpdating = True

End Sub
Click to expand...
Just tried this code, and it's pdf-ing just the first page for each sheet, and not the second. But it is getting all the sheet numbers, it's missing the second page on all of them
 
Upvote 0
I would need to see your data for at least one of the sheets, it is working fine for me.
Actually I don't need to see the exact date but I need it to have all the same rows and columns populated and with all the rows and column having the exact same sizes as you have them.

You might like to change your xlPortrait to xlLandscape first.
 
Upvote 0
Alex Blakenburg said:
I would need to see your data for at least one of the sheets, it is working fine for me.
Actually I don't need to see the exact date but I need it to have all the same rows and columns populated and with all the rows and column having the exact same sizes as you have them.

You might like to change your xlPortrait to xlLandscape first.
Click to expand...
 
Upvote 0
Here's a minisheet, hopefully it copied over correctly. I need to keep it in xlPortrait, per my company's direction. Let me know if this worked. The Task Management section is the part that varies from sheet to sheet. Some have multiple pages, others just have one.

Example Tracker.xlsm
ABCDEFGHIJKLM
1
2
3
4PROJECT INFORMATION
5MPMS #COUNTY #PROJECT NAMEDESCRIPTION
6272196072-0401Campbell's Run Road
7FEDERAL PROJECT NUMBEROVERSIGHTFUND SHAREFUND
8X111-271, X111-245 (ROW), 1720-101 (Cstr)Federal80-20
9
10PROJECT TEAM
11DESIGNERPENNDOT PMADDITIONAL TEAM MEMBERSCOUNTY PM PM SERVICES
12
13
14MILESTONES
15PRELIMINARY ENGINEERINGFINAL DESIGNCONSTRUCTION
16PennDOT ConnectsFD NTPAdvertise
17Scoping Field ViewROW PlanLet Date
18Prelim Eng. NTP60% Cstr ReviewNTP to Contractor
19Inspection / SurveyRR AgreementPhys Work Comp
20Data CollectionPermitsAcceptance Cert
21SUE Impact FormFDOMComplete
22Line & GradeStr Adequacy
23TS&LFinal SRC MeetingNOTES
24Prelim ROW Plan100% Cstr Review
25Prelim SRC MeetingUtility Clearance
26Design Field ViewROW Clearance
27Enviro ClearanceFinal PS&E
28
29AGREEMENT DATES
304232 PE4232 FD4232 CSTRRA- R20110006DESIGNER- PaperPM SERVICES- L464OTHER 1OTHER 2OTHER 3
31EFFECTIVE4/1/19859/30/2020
32EXPIRATION9/30/2021*NA12/31/2025
33
34FUNDING SUMMARY
35PHASE NEED 4232 4232 AC RA TOTAL TIP2021202220232024Previous TIP
37PE$ -$ 1,964,723.00$ -$ 1,520,000.00$ 1,964,723.00$ -$ -$ -$ -$ 1,964,723.00
38FD$ 4,411,362.00$ 4,922,190.00$ -$ 3,015,171.00$ 4,610,949.00$ -$ -$ -$ -$ 4,610,949.00
39UTL$ 1,625,000.00$ 1,625,000.00$ -$ 400,000.00$ 1,640,000.00$ 600,000.00$ -$ -$ -$ 1,040,000.00
40ROW$ 6,175,000.00$ 5,235,000.00$ -$ 2,000,000.00$ 6,175,000.00$ -$ -$ -$ -$ 6,175,000.00
41CON$ 33,075,000.00$ -$ -$ -#############$ -$ 3,437,500.00$ 7,500,000.00$ 3,300,956.00
42
43EXPENDITURE DETAILS
44PHASETOTALDESIGNERPENNDOTACDPWPM SERVICESOTHER 1OTHER 2OTHER 3
47PEBUDGET$ -$ -$ -$ -$ -$ -$ -$ -
48COSTS$ -$ -$ -$ -$ -$ -$ -$ -
49FDBUDGET$ 4,411,362.00$ 4,411,362.00$ -$ -$ -$ -$ -$ -
50COSTS$ -$ -$ -$ -$ -$ -$ -$ -
51UTLBUDGET$ 1,625,000.00$ 1,625,000.00$ -$ -$ -$ -$ -$ -
52COSTS$ -$ -$ -$ -$ -$ -$ -$ -
53ROWBUDGET$ 6,175,000.00$ 6,175,000.00$ -$ -$ -$ -$ -$ -
54COSTS$ -$ -$ -$ -$ -$ -$ -$ -
55PHASETOTALDESIGNERPENNDOTACDPWPM SERVICESOTHER 1OTHER 2OTHER 3CONTRACTORCM/CI
56CONBUDGET$ 33,075,000.00$ 33,075,000.00$ -$ -$ -$ -$ -$ -$ -$ -
57COSTS$ -$ -$ -$ -$ -$ -$ -$ -$ -$ -
58
59TASK MANAGEMENT
60MEETING DATEDISCUSSIONACTION REQUIREDBYDUECOMPLETE
616/29/2021URPennDOT6/28/20216/15/2021
62URACDPW6/30/20217/1/2021
634/20/2021URPennDOT4/30/2021
642/9/2021URACDPW2/9/20212/3/2021
65URSAI/ACDPW11/1/2021
6612/8/2020URPennDOT2/1/20212/5/2021
67URACDPW2/3/2021Complete
689/29/2020URPennDOT9/30/202010/26/2021
697/28/2020URACDPW8/15/20208/7/2020
70URACDPW7/31/20208/20/2020
715/12/2020URACDPW5/29/20206/3/2020
72URPennDOT5/29/20206/29/2020
733/10/2020URPennDOT8/8/201910/21/2019
74URPennDOT2/12/20208/12/2020
75URPennDOT2/26/20205/27/2020
76URPennDOT / ACDPW3/13/2020Complete
779/17/2019URACDPW9/26/20196/4/2020
27219
Cell Formulas
RangeFormula
D6D6=IFERROR(VLOOKUP(B6,DASHBOARD!B4:D38,2,FALSE),"")
F6F6=IFERROR(VLOOKUP(B6,DASHBOARD!B4:D38,3,FALSE),"")
D37:D41D37=SUMIFS(CONTRACT_SUMMARY!F:F,CONTRACT_SUMMARY!D:D,B37,CONTRACT_SUMMARY!A:A,$B$6)
E37:E41E37=SUMIFS(FORM_4232!K:K,FORM_4232!F:F,B37,FORM_4232!A:A,$B$6)
F37:F41F37=SUMIFS(FORM_4232!H:H,FORM_4232!F:F,B37,FORM_4232!A:A,$B$6)
G37:G41G37=SUMIFS(REIMB_AGREEMENTS!K:K,REIMB_AGREEMENTS!G:G,B37,REIMB_AGREEMENTS!A:A,$B$6)
H37:H41H37=SUM(I37:M37)
I37:I41I37=SUMIFS(TIP_SUMMARY!L:L,TIP_SUMMARY!I:I,B37,TIP_SUMMARY!F:F,$B$6,TIP_SUMMARY!J:J,TIP_SUMMARY!$A$3)
J37:J41J37=SUMIFS(TIP_SUMMARY!L:L,TIP_SUMMARY!I:I,B37,TIP_SUMMARY!F:F,$B$6,TIP_SUMMARY!J:J,TIP_SUMMARY!$B$3)
K37:K41K37=SUMIFS(TIP_SUMMARY!L:L,TIP_SUMMARY!I:I,B37,TIP_SUMMARY!F:F,$B$6,TIP_SUMMARY!J:J,TIP_SUMMARY!$C$3)
L37:L41L37=SUMIFS(TIP_SUMMARY!L:L,TIP_SUMMARY!I:I,B37,TIP_SUMMARY!F:F,$B$6,TIP_SUMMARY!J:J,TIP_SUMMARY!$D$3)
D47:D54,D57D47=SUM(E47:K47)
E47:K47,E49:K49,E51:K51,E53:K53,E56:K56E47=SUMIFS(CONTRACT_SUMMARY!$F:$F,CONTRACT_SUMMARY!$D:$D,$B47,CONTRACT_SUMMARY!$A:$A,$B$6,CONTRACT_SUMMARY!$B:$B,E$44)
E48:K48E48=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$47,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
E50:K50E50=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$49,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
E52:K52E52=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$51,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
E54:K54E54=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$53,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
D56D56=SUM(E56:M56)
L56:M56L56=SUMIFS(CONTRACT_SUMMARY!$F:$F,CONTRACT_SUMMARY!$D:$D,$B56,CONTRACT_SUMMARY!$A:$A,$B$6,CONTRACT_SUMMARY!$B:$B,L$55)
E57:K57E57=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$56,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
L57:M57L57=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$56,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,L$55)
 
Upvote 0
Ahh the dreaded Merged Cells.
The code is using Column M to determine the last row but it is merged for the bottom section and in fact empty.

Change this:
VBA Code: 
lastRow = .Cells(Rows.Count, "M").End(xlUp).Row

To using column B to determine the lastRow
VBA Code: 
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
 
Upvote 0
Solution
Alex Blakenburg said:
Ahh the dreaded Merged Cells.
The code is using Column M to determine the last row but it is merged for the bottom section and in fact empty.

Change this:
VBA Code: 
lastRow = .Cells(Rows.Count, "M").End(xlUp).Row

To using column B to determine the lastRow
VBA Code: 
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Click to expand...
Thank you so much! That code works!
 
Upvote 0
You must log in or register to reply here.

Similar threads

imback2nite
  • Question Question
Print size change using VBA.
Replies
4
Views
322
imback2nite
imback2nite
K
  • Question Question
80mm Thermal Printer (PSO-80) affects me PDF range
Replies
0
Views
54
kapela2017
K
A
  • Question Question
VBA for setting up the printing pages per sheet
Replies
0
Views
494
Aurum1
A
S
  • Question Question
Excel macros extremely slow
Replies
4
Views
417
Shloime
S
G
  • Solved
Still no solution after 1 Year - Please Help
2
Replies
10
Views
781
jolivanes
jolivanes

Forum statistics

Threads
1,223,911
Messages
6,175,324
Members
452,635
Latest member
laura12345

Share this page

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
Back
Top