VBA Set Print Area Based on Cell Reference

Question

I put down together the following code. It basically loops through a path and converts all of the Excel workbooks into PDF.

I would like to setup the print area based on cell references. Cell C8 and D8

C8 = Column A - start of print area D8 = Column M - end of print area

For example, I want the print area to start from column A - M. However, the current code prints everything, past column M

If settingsSheet.Range("C8").Value = vbNullString Or settingsSheet.Range("D8").Value = vbNullString Then

GoTo ABC

Else

reportColumnsAddr = settingsSheet.Range("C8").Value & ":" & settingsSheet.Range("D8").Value
Set reportSheet = Sheets(reportSheetName) 
reportSheet.PageSetup.PrintArea = reportSheet.Columns(reportColumnsAddr).Address

End If

ABC:

Full code


Option Explicit


Private Sub CommandButton1_Click()

Dim MyFolder As String, MyFile As String
Dim StartTime As Double
Dim MinutesElapsed As String
Dim Filename As String
Dim Cell As String
Dim Counter As Long

If ThisWorkbook.Sheets("Sheet1").Range("C7").Value = vbNullString Then

MsgBox "Enter Tab Name"
Exit Sub

End If

With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a Folder"
If .Show = True Then
MyFolder = .SelectedItems(1)

End If

If .SelectedItems.Count = 0 Then Exit Sub
Err.Clear


End With

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic

MyFile = Dir(MyFolder & "\", vbReadOnly)


StartTime = Timer


Do While MyFile <> ""

DoEvents

On Error GoTo 0

Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False

Dim settingsSheet As Worksheet 'Source
Dim reportSheet As Worksheet 'To convert to PDF
Dim targetColumnsRange As Range 'feeds from source
Dim targetRowsRange As Range
Dim reportSheetName As String 'source sheet with the target's sheet name
Dim reportColumnsAddr As String
Dim reportRowsAddr As String
Dim WidthFit As String
Dim LengthFit As String

Set settingsSheet = ThisWorkbook.Worksheets("Sheet1") ' source

' Gather the report sheet's name



reportSheetName = settingsSheet.Range("C7").Value ' good

WidthFit = settingsSheet.Range("G8").Value
LengthFit = settingsSheet.Range("G9").Value

On Error Resume Next

Set reportSheet = Sheets(reportSheetName)
On Error GoTo 0 
If reportSheet Is Nothing Then
MsgBox "No Sheet Named '" & reportSheetName & "' in This Workbook!"
Exit Sub

End If 

If settingsSheet.Range("C8").Value = vbNullString Or settingsSheet.Range("D8").Value = vbNullString Then

GoTo ABC 

Else

reportColumnsAddr = settingsSheet.Range("C8").Value & ":" & settingsSheet.Range("D8").Value
Set reportSheet = Sheets(reportSheetName)

reportSheet.PageSetup.PrintArea = reportSheet.Columns(reportColumnsAddr).Address

End If

ABC: 

If WidthFit = "YES" Then

With reportSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1

End With
End If

If LengthFit = "YES" Then

With reportSheet.PageSetup
.Zoom = False
.FitToPagesTall = 1

End With

End If


Filename = ActiveWorkbook.Name 
Cell = Replace(Filename, ".xlsx", ".PDF")
reportSheet.Select 
If settingsSheet.Range("J8").Value = "Landscape" Then
reportSheet.PageSetup.Orientation = xlLandscape

Else

reportSheet.PageSetup.Orientation = xlPortrait

End If


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Cell, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False

Counter = Counter + 1

0

Workbooks(MyFile).Close SaveChanges:=False

MyFile = Dir

Loop

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")

MsgBox "Successfully Converted " & Counter & " Files in " & MinutesElapsed & " minutes", vbInformation


End Sub

chris neilsen · Accepted Answer

Your error is you have set IgnorePrintAreas:=True, _ in reportSheet.ExportAsFixedFormat

That said, there are many other issues in your code:

Implicit ActiveWorkbook references
Unnecessary repetition of code in the loop
Case sensitive tests
Misleading variable names
Unnecessary use of GoTo
Malformed error handling
Could try to open non xlsx files
Incomplete checks of user Settings entry

Here's a refactor of your code

Private Sub CommandButton1_Click()
    Dim MyFolder As String, MyFile As String
    Dim StartTime As Double
    Dim TimeElapsed As String
    Dim Filename As String
    Dim PdfFileName As String
    Dim Counter As Long
    Dim Orientation As XlPageOrientation

    Dim settingsSheet As Worksheet 'Source
    Dim reportSheet As Worksheet 'To convert to PDF
    Dim targetColumnsRange As Range 'feeds from source
    Dim targetRowsRange As Range
    Dim reportSheetName As String 'source sheet with the target's sheet name
    Dim reportColumnsAddr As String
    Dim reportRowsAddr As String
    Dim WidthFit As String
    Dim LengthFit As String
    Dim wb As Workbook

    ' Set a reference to the settings sheet
    Set settingsSheet = ThisWorkbook.Worksheets("Sheet1") ' source
    With settingsSheet
        If .Range("C7").Value = vbNullString Then
            MsgBox "Enter Tab Name"
            Exit Sub
        End If
        If .Range("C8").Value = vbNullString Or .Range("D8").Value = vbNullString Then
            MsgBox "Enter Valid Columns"
            Exit Sub
        End If
        reportColumnsAddr = .Range("C8").Value & ":" & .Range("D8").Value
        On Error Resume Next
            Set targetColumnsRange = .Columns(reportColumnsAddr)
        On Error GoTo 0
        If targetColumnsRange Is Nothing Then
            MsgBox "Enter Valid Columns"
            Exit Sub
        End If
        Set targetColumnsRange = Nothing

        reportSheetName = .Range("C7").Value ' good
        WidthFit = .Range("G8").Value
        LengthFit = .Range("G9").Value

        Orientation = IIf(StrComp(.Range("J8").Value, "Landscape", vbTextCompare) = 0, xlLandscape, xlPortrait)
    End With


    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Select a Folder"
        If .Show = True Then
            MyFolder = .SelectedItems(1)
        End If

        If .SelectedItems.Count = 0 Then Exit Sub
        Err.Clear
    End With

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationAutomatic

    MyFile = Dir(MyFolder & "\*.xlsx", vbReadOnly)
    StartTime = Timer()
    Do While MyFile <> ""
        DoEvents
        On Error Resume Next
            Set wb = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False)
        On Error GoTo 0

        If wb Is Nothing Then
            MsgBox "Failed to open " & MyFolder & "\" & MyFile
            GoTo CleanUp
        End If

        Set reportSheet = Nothing
        On Error Resume Next
            Set reportSheet = wb.Worksheets(reportSheetName)
        On Error GoTo 0
        If reportSheet Is Nothing Then
            MsgBox "No Sheet Named '" & reportSheetName & "' in This Workbook!"
            GoTo CleanUp
        End If

        reportSheet.PageSetup.PrintArea = reportColumnsAddr

        If StrComp(WidthFit, "YES", vbTextCompare) = 0 Then
            With reportSheet.PageSetup
                .Zoom = False
                .FitToPagesWide = 1
            End With
        End If

        If StrComp(LengthFit, "YES", vbTextCompare) = 0 Then
            With reportSheet.PageSetup
                .Zoom = False
                .FitToPagesTall = 1
            End With
        End If

        PdfFileName = Replace(wb.Name, ".xlsx", ".PDF")

        reportSheet.PageSetup.Orientation = Orientation

        reportSheet.ExportAsFixedFormat _
          Type:=xlTypePDF, _
          Filename:=ThisWorkbook.Path & "\" & PdfFileName, _
          Quality:=xlQualityStandard, _
          IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, _
          OpenAfterPublish:=False

        Counter = Counter + 1

        wb.Close SaveChanges:=False
        MyFile = Dir
    Loop
CleanUp:
    On Error Resume Next
    wb.Close False
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

    TimeElapsed = Format((Timer() - StartTime) / 86400, "hh:mm:ss")
    MsgBox "Successfully Converted " & Counter & " Files in " & TimeElapsed, vbInformation
End Sub

VBA Set Print Area Based on Cell Reference

Answers (1)

Related Questions