VBA Set Print Area Based on Cell Reference - excel

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

Answer 1

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