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

您的錯誤是您在reportSheet.ExportAsFixedFormat設置了IgnorePrintAreas:=True, _

也就是說，您的代碼中還有許多其他問題：

• 隱式ActiveWorkbook引用
• 循環中不必要的代碼重復
• 區分大小寫的測試
• 誤導性的變量名
• 不必要地使用 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