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