VBA批量导出Excel为PDF时忽略打印区域输出页数异常问题求助

代码错误根因 #

• 错误使用工作表选择+ActiveSheet导出逻辑：选中多工作表后调用ActiveSheet.ExportAsFixedFormat只会导出当前激活的单个工作表，且选择操作本身容易受工作簿原有激活状态干扰，导致打印区域读取异常
• 没有显式绑定工作表的页面设置参数：即使IgnorePrintAreas:=False，打开外部工作簿时偶尔会出现打印区域临时读取失效的情况
• 自定义函数调用前缀错误：自己定义的GetNextAvailableFilename函数不需要加EFDK.前缀，调用不一致可能导致路径生成异常
• 全局名称引用错误：代码中[KompletPoliceNr]、[Forsikringstager]这类名称默认读取当前运行代码的工作簿取值，如果你需要读取新打开的wb里的名称，需要显式指定，避免取值错误

修复后完整代码 #

Sub BatchExportExcelToPDF()
    Dim wb As Workbook
    Dim xExtension As String: xExtension = "*.xls*"
    Dim xFolder As String: xFolder = ThisWorkbook.Names("MailFolder").RefersToRange.Value ' 显式读取当前代码工作簿的名称值
    Dim xFile As String: xFile = Dir(xFolder & xExtension)
    Dim policeNr As String, holder As String

    Do While xFile <> ""
        Set wb = Workbooks.Open(xFolder & xFile)
        ' 显式读取打开的工作簿内的名称值，避免取值错误
        policeNr = wb.Names("KompletPoliceNr").RefersToRange.Value
        holder = wb.Names("Forsikringstager").RefersToRange.Value
        
        Call WorksheetsToPDF(wb, "F:\VBA\PDF\Udlejning\" & CleanFileName("Police - 2021 -" & policeNr & " - " & holder) & ".pdf", "Certifikat")
        ' 取消注释即可导出Police工作表
        'Call WorksheetsToPDF(wb, "F:\VBA\KF Begæringer\" & CleanFileName("KF Begæring-2021-" & policeNr & "-" & holder) & ".pdf", "Police")
        
        wb.Close SaveChanges:=False
        xFile = Dir()
    Loop
End Sub

Private Sub WorksheetsToPDF(wb As Workbook, DistinationPath As String, ParamArray Arr() As Variant)
    Dim ws As Worksheet
    ' 强制刷新每个目标工作表的打印区域缓存，避免失效
    For Each ws In wb.Sheets(Arr())
        ws.PageSetup.PrintArea = ws.PageSetup.PrintArea
    Next
    ' 直接对指定工作表集合执行导出，无需选中工作表，避免状态干扰
    wb.Sheets(Arr()).ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=GetNextAvailableFilename(DistinationPath), _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
End Sub

Private Function GetNextAvailableFilename(ByVal xPath As String) As String
    With CreateObject("Scripting.FileSystemObject")
        Dim strFolder As String, strBaseName As String, strExt As String, i As Long
        strFolder = .GetParentFolderName(xPath)
        strBaseName = .GetBaseName(xPath)
        strExt = .GetExtensionName(xPath)

        Do While .FileExists(xPath)
            i = i + 1
            xPath = .BuildPath(strFolder, strBaseName & " - " & i & "." & strExt)
        Loop
    End With
    GetNextAvailableFilename = xPath
End Function

可选优化 #

如果依然出现空白页，可以在上述的页面设置循环中，显式指定和手动打印一致的适配参数：

With ws.PageSetup
    .FitToPagesTall = 4 ' 按你实际手动打印的页数调整
    .FitToPagesWide = 1
    .CenterHorizontally = True
End With

内容的提问来源于stack exchange，提问作者Anne