Set Dynamic Print Range

km10 · Sep 1, 2021

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

Alex Blakenburg · Sep 2, 2021

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

km10 · Sep 3, 2021

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

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

Alex Blakenburg · Sep 3, 2021

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.

km10 · Sep 3, 2021

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.

km10 · Sep 3, 2021

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

A

B

C

D

E

F

G

H

I

J

K

L

M

1

2

3

4

PROJECT INFORMATION

5

MPMS #

COUNTY #

PROJECT NAME

DESCRIPTION

6

27219

6072-0401

Campbell's Run Road

7

FEDERAL PROJECT NUMBER

OVERSIGHT

FUND SHARE

FUND

8

X111-271, X111-245 (ROW), 1720-101 (Cstr)

Federal

80-20

9

10

PROJECT TEAM

11

DESIGNER

PENNDOT PM

ADDITIONAL TEAM MEMBERS

COUNTY PM

PM SERVICES

12

13

14

MILESTONES

15

PRELIMINARY ENGINEERING

FINAL DESIGN

CONSTRUCTION

16

PennDOT Connects

FD NTP

Advertise

17

Scoping Field View

ROW Plan

Let Date

18

Prelim Eng. NTP

60% Cstr Review

NTP to Contractor

19

Inspection / Survey

RR Agreement

Phys Work Comp

20

Data Collection

Permits

Acceptance Cert

21

SUE Impact Form

FDOM

Complete

22

Line & Grade

Str Adequacy

23

TS&L

Final SRC Meeting

NOTES

24

Prelim ROW Plan

100% Cstr Review

25

Prelim SRC Meeting

Utility Clearance

26

Design Field View

ROW Clearance

27

Enviro Clearance

Final PS&E

28

29

AGREEMENT DATES

30

4232 PE

4232 FD

4232 CSTR

RA- R20110006

DESIGNER- Paper

PM SERVICES- L464

OTHER 1

OTHER 2

OTHER 3

31

EFFECTIVE

4/1/1985

9/30/2020

32

EXPIRATION

9/30/2021*

NA

12/31/2025

33

34

FUNDING SUMMARY

35

PHASE

NEED

4232

4232 AC

RA

TOTAL TIP

2021

2022

2023

2024

Previous TIP

37

PE

$ 1,964,723.00

38

FD

$ 4,610,949.00

39

UTL

$ 1,040,000.00

40

ROW

$ 6,175,000.00

41

CON

42

43

EXPENDITURE DETAILS

44

PHASE

TOTAL

DESIGNER

PENNDOT

ACDPW

PM SERVICES

OTHER 1

OTHER 2

OTHER 3

47

PE

BUDGET

$ -

48

COSTS

$ -

49

FD

BUDGET

$ 4,411,362.00

$ -

50

COSTS

$ -

51

UTL

BUDGET

$ 1,625,000.00

$ -

52

COSTS

$ -

53

ROW

BUDGET

$ 6,175,000.00

$ -

54

COSTS

$ -

55

PHASE

TOTAL

DESIGNER

PENNDOT

ACDPW

PM SERVICES

OTHER 1

OTHER 2

OTHER 3

CONTRACTOR

CM/CI

56

CON

BUDGET

$ 33,075,000.00

$ -

57

COSTS

$ -

58

59

TASK MANAGEMENT

60

MEETING DATE

DISCUSSION

ACTION REQUIRED

BY

DUE

COMPLETE

61

6/29/2021

U

R

PennDOT

6/28/2021

6/15/2021

62

U

R

ACDPW

6/30/2021

7/1/2021

63

4/20/2021

U

R

PennDOT

4/30/2021

64

2/9/2021

U

R

ACDPW

2/9/2021

2/3/2021

65

U

R

SAI/ACDPW

11/1/2021

66

12/8/2020

U

R

PennDOT

2/1/2021

2/5/2021

67

U

R

ACDPW

2/3/2021

Complete

68

9/29/2020

U

R

PennDOT

9/30/2020

10/26/2021

69

7/28/2020

U

R

ACDPW

8/15/2020

8/7/2020

70

U

R

ACDPW

7/31/2020

8/20/2020

71

5/12/2020

U

R

ACDPW

5/29/2020

6/3/2020

72

U

R

PennDOT

5/29/2020

6/29/2020

73

3/10/2020

U

R

PennDOT

8/8/2019

10/21/2019

74

U

R

PennDOT

2/12/2020

8/12/2020

75

U

R

PennDOT

2/26/2020

5/27/2020

76

U

R

PennDOT / ACDPW

3/13/2020

Complete

77

9/17/2019

U

R

ACDPW

9/26/2019

6/4/2020

27219

Cell Formulas
Range	Formula
D6	D6	=IFERROR(VLOOKUP(B6,DASHBOARD!B4:D38,2,FALSE),"")
F6	F6	=IFERROR(VLOOKUP(B6,DASHBOARD!B4:D38,3,FALSE),"")
D37:D41	D37	=SUMIFS(CONTRACT_SUMMARY!F:F,CONTRACT_SUMMARY!D:D,B37,CONTRACT_SUMMARY!A:A,$B$6)
E37:E41	E37	=SUMIFS(FORM_4232!K:K,FORM_4232!F:F,B37,FORM_4232!A:A,$B$6)
F37:F41	F37	=SUMIFS(FORM_4232!H:H,FORM_4232!F:F,B37,FORM_4232!A:A,$B$6)
G37:G41	G37	=SUMIFS(REIMB_AGREEMENTS!K:K,REIMB_AGREEMENTS!G:G,B37,REIMB_AGREEMENTS!A:A,$B$6)
H37:H41	H37	=SUM(I37:M37)
I37:I41	I37	=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:J41	J37	=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:K41	K37	=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:L41	L37	=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,D57	D47	=SUM(E47:K47)
E47:K47,E49:K49,E51:K51,E53:K53,E56:K56	E47	=SUMIFS(CONTRACT_SUMMARY!$F:$F,CONTRACT_SUMMARY!$D:$D,$B47,CONTRACT_SUMMARY!$A:$A,$B$6,CONTRACT_SUMMARY!$B:$B,E$44)
E48:K48	E48	=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$47,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
E50:K50	E50	=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$49,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
E52:K52	E52	=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$51,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
E54:K54	E54	=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$53,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
D56	D56	=SUM(E56:M56)
L56:M56	L56	=SUMIFS(CONTRACT_SUMMARY!$F:$F,CONTRACT_SUMMARY!$D:$D,$B56,CONTRACT_SUMMARY!$A:$A,$B$6,CONTRACT_SUMMARY!$B:$B,L$55)
E57:K57	E57	=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$56,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,E$44)
L57:M57	L57	=SUMIFS(INVOICE_TRACKER!$P:$P,INVOICE_TRACKER!$D:$D,$B$56,INVOICE_TRACKER!$A:$A,$B$6,INVOICE_TRACKER!$C:$C,L$55)

Alex Blakenburg · Sep 3, 2021

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

km10 · Sep 6, 2021

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

Thank you so much! That code works!

Alex Blakenburg · Sep 6, 2021

Thanks for letting us know. Glad we could help.

Set Dynamic Print Range

km10

New Member

Alex Blakenburg

MrExcel MVP

Excel Facts

km10

New Member

Alex Blakenburg

MrExcel MVP

km10

New Member

km10

New Member

Alex Blakenburg

MrExcel MVP

km10

New Member

Alex Blakenburg

MrExcel MVP

Similar threads

Forum statistics

Share this page

Set Dynamic Print Range

New Member

MrExcel MVP

Excel Facts

New Member

MrExcel MVP

New Member

New Member

MrExcel MVP

New Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock