VBA Установить область печати на основе ссылки на ячейку

Question

Я записал следующий код. Он в основном проходит по пути и преобразует все книги Excel в PDF.

Я хотел бы настроить область печати на основе ссылок на ячейки. Ячейки C8 и D8

C8 = столбец A - начало области печати D8 = столбец M - конец области печати

Например, я хочу, чтобы область печати начиналась со столбца A - M. Тем не менее, текущий код печатает все, кроме столбца 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:

Полный код

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

Ваша ошибка: вы установили IgnorePrintAreas:=True, _ в reportSheet.ExportAsFixedFormat

Тем не менее, в вашем коде есть много других проблем:

• Неявные ActiveWorkbook ссылки
• Ненужное повторение кода в l oop
• Чувствительные к регистру тесты
• Вводящие в заблуждение имена переменных
• Ненужное использование GoTo
• Неправильная ошибка обработка
• Можно попытаться открыть файлы не xlsx
• Неполные проверки ввода пользовательских настроек

Вот рефакторинг вашего кода

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