Excel VBA批量导出多工作表PDF时打印区域异常求助

使用Excel VBA批量打印多个工作表时，程序会将所选工作表中第一个表的打印区域应用到所有其他表，无法按各工作表自身设置的打印区域导出PDF。尝试过多种工作表选择方式，结果一致。需要实现不硬编码指定工作表的前提下，导出各表各自打印区域的PDF。

原代码如下：

Sub printsheets()
   Dim rng As Range, cell As Range, sht As String, arraylist() As String, i As Integer, j As Integer
   Dim selectsheets As Sheets
   Dim fldr As FileDialog
   Dim sItem As String
   
   Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
   Set rng = Range("_mapLab")
   i = 0
   j = Application.WorksheetFunction.CountA(Range("_map_Lab")) - 1
   
   ReDim arraylist(j)
   With ActiveWorkbook
      For Each cell In rng
         sht = cell
         If sht = "" Then
            Exit For
         End If
         .Worksheets(sht).Activate
         .Worksheets(sht).Range(Worksheets(sht).PageSetup.PrintArea).Select
         arraylist(i) = sht
         i = i + 1
      Next cell
   End With
   
   ThisWorkbook.Sheets(arraylist).Select
   With fldr
      .title = "Select a Folder"
      .AllowMultiSelect = False
      .InitialFileName = Application.DefaultFilePath
      If .SHOW <> -1 Then GoTo NextCode
      sItem = .SelectedItems(1) & "\"
   End With
   
NextCode:
   Selection.ExportAsFixedFormat Type:=xlTypePDF, _
                 FileName:=sItem & ActiveWorkbook.Name & ".pdf", _
                 Quality:=xlQualityStandard, _
                 IncludeDocProperties:=True, _
                 IgnorePrintAreas:=False, _
                 OpenAfterPublish:=True
End Sub

解决方案 #

问题根源 #

选中多个工作表执行ExportAsFixedFormat时，Excel会统一使用第一个选中工作表的打印配置（包括打印区域），这是Excel的默认行为，无法通过调整选择方式解决。必须逐个导出每个工作表，再合并PDF文件。

修改后代码（支持自动合并PDF） #

Sub ExportEachSheetToPDFAndMerge()
    Dim rng As Range, cell As Range
    Dim shtName As String
    Dim fldr As FileDialog
    Dim savePath As String
    Dim tempFiles As Collection
    Dim acroApp As Object
    Dim acroPDDoc As Object
    Dim acroPDDocTemp As Object
    Dim i As Integer
    
    ' 选择保存文件夹
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "选择保存文件夹"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then Exit Sub
        savePath = .SelectedItems(1) & "\"
    End With
    
    ' 存储临时PDF路径的集合
    Set tempFiles = New Collection
    
    ' 遍历需要导出的工作表
    Set rng = Range("_mapLab")
    For Each cell In rng
        shtName = cell.Value
        If shtName = "" Then Exit For
        
        ' 检查工作表是否存在
        On Error Resume Next
        Dim targetSht As Worksheet
        Set targetSht = ThisWorkbook.Worksheets(shtName)
        On Error GoTo 0
        
        If Not targetSht Is Nothing Then
            ' 导出单个工作表的PDF（使用自身打印区域）
            Dim tempPDFPath As String
            tempPDFPath = savePath & "Temp_" & shtName & ".pdf"
            targetSht.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=tempPDFPath, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
            tempFiles.Add tempPDFPath
            Set targetSht = Nothing
        End If
    Next cell
    
    ' 如果没有要导出的工作表，退出
    If tempFiles.Count = 0 Then
        MsgBox "没有有效的工作表需要导出", vbInformation
        Exit Sub
    End If
    
    ' 尝试初始化Acrobat对象（需安装完整版Adobe Acrobat）
    On Error Resume Next
    Set acroApp = CreateObject("AcroExch.App")
    On Error GoTo 0
    
    If acroApp Is Nothing Then
        ' 无Acrobat时提示手动合并
        MsgBox "未检测到Adobe Acrobat，已将各工作表导出为单独PDF，路径：" & savePath & vbCrLf & "请手动合并这些文件。", vbInformation
        Exit Sub
    End If
    
    ' 创建主PDF文档
    Set acroPDDoc = CreateObject("AcroExch.PDDoc")
    acroPDDoc.Open tempFiles(1)
    
    ' 合并其他临时PDF
    For i = 2 To tempFiles.Count
        Set acroPDDocTemp = CreateObject("AcroExch.PDDoc")
        If acroPDDocTemp.Open(tempFiles(i)) Then
            acroPDDoc.InsertPages acroPDDoc.GetNumPages - 1, acroPDDocTemp, 0, acroPDDocTemp.GetNumPages, False
            acroPDDocTemp.Close
        End If
        Set acroPDDocTemp = Nothing
    Next i
    
    ' 保存合并后的PDF
    Dim finalPDFPath As String
    finalPDFPath = savePath & ThisWorkbook.Name & ".pdf"
    acroPDDoc.Save 1, finalPDFPath ' 1 = PDSaveFull
    acroPDDoc.Close
    acroApp.Exit
    
    ' 删除临时PDF文件
    For Each tempFile In tempFiles
        Kill tempFile
    Next tempFile
    
    ' 打开合并后的PDF
    Shell "explorer.exe " & Chr(34) & finalPDFPath & Chr(34), vbNormalFocus
    
    ' 释放对象
    Set acroPDDoc = Nothing
    Set acroApp = Nothing
    Set tempFiles = Nothing
    MsgBox "PDF导出并合并完成", vbInformation
End Sub

注意事项 #

1. Adobe Acrobat依赖：自动合并功能需要安装完整版Adobe Acrobat（非免费Reader），若未安装，代码会自动导出单独PDF并提示手动合并。
2. 工作表有效性检查：代码会验证指定的工作表是否存在，避免无效表名导致报错。
3. 临时文件处理：合并完成后会自动删除临时PDF文件，无需手动清理。

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