创建单个 PDF 文件而不是多个

Question

我一直在使用此代码创建多个 PDF 文件，我想将所有图片保存在单个 PDF 文件中，但在单独的页面中。

我做了很多尝试，但找不到这件事会如何发生。非常感谢您的帮助。

Sub ExpPdf()
  Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
  
  Set sh = Sheet17
  lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
  
  ReDim arr(lastR - 1)
  For i = 6 To lastR
        If sh.Range("E" & i).Value = "Include" Then
            arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
        End If
  Next i
  If k > 0 Then
        ReDim Preserve arr(k - 1)
  Else
        MsgBox "No appropriate range (containing ""Include"") could be found...:exit sub"
  End If
  Dim boolHide As Boolean, boolProt As Boolean
  ActiveWorkbook.Unprotect "4321"
  For i = 0 To UBound(arr)
        boolHide = False: boolProt = False
        arrSplit = Split(arr(i), "|")
        Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
        
        If ActiveWorkbook.Sheets(arrSplit(0)).ProtectContents Then _
                ActiveWorkbook.Sheets(arrSplit(0)).Unprotect "4321": boolProt = True
                Debug.Print arrSplit(0)
        If ActiveWorkbook.Sheets(arrSplit(0)).Visible <> xlSheetVisible Then _
                ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetVisible: boolHide = True
        
        
        Dim saveLocation As String
        
        saveLocation = ThisWorkbook.Path & "\" & arrSplit(0) & ".pdf"
        
    
        rng.ExportAsFixedFormat Type:=xlTypePDF, FILENAME:= _
          saveLocation, Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=True
         If boolHide Then ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetHidden
         If boolProt Then ActiveWorkbook.Sheets(arrSplit(0)).Protect "4321"
  Next
  ActiveWorkbook.Protect "4321"
End Sub

Answer 1

循环浏览每张纸，然后设置 PrintArea。打印区域将是您指定的范围。然后将每个 PrintArea 导出到 PDF 文件中的单个页面。

Sub ExpPdf()
    Dim sh As Worksheet, lastR As Long, rng As Range, arr, arr2, arr3, arrSplit, i As Long, k, l, m As Long

    Set sh = Sheet17
    lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
    
    ReDim arr(lastR - 1)
    For i = 6 To lastR
          If sh.Range("E" & i).Value = "Include" Then
              arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
          End If
    Next i
    If k > 0 Then
          ReDim Preserve arr(k - 1)
    Else
          MsgBox "No appropriate range (containing ""Include"") could be found...:exit sub"
    End If
    Dim boolHide As Boolean, boolProt As Boolean
    ActiveWorkbook.Unprotect "4321" 'in order to unprotect he workbook structure
      
              
    'Create and assign variables
    Dim saveLocation As String
    saveLocation = ThisWorkbook.path & "\" & Format(Now(), "mm-dd-yy, hh.mm.ss") & " - " & Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1) & ".pdf"
        
    ReDim arr2(UBound(arr))
    ReDim arr3(UBound(arr))
    For i = 0 To UBound(arr)
          boolHide = False: boolProt = False
          arrSplit = Split(arr(i), "|")
          If ActiveWorkbook.Sheets(arrSplit(0)).ProtectContents Then _
          ActiveWorkbook.Sheets(arrSplit(0)).Unprotect "4321": boolProt = True
          Debug.Print arrSplit(0)
          If ActiveWorkbook.Sheets(arrSplit(0)).Visible <> xlSheetVisible Then _
          ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetVisible: boolHide = True
          arr2(l) = arrSplit(0): l = l + 1
          arr3(m) = arrSplit(1): m = m + 1
    Next i
    
    Dim path As String
    Dim myArr As Variant, a As Variant
    
    For i = 0 To UBound(arr2)
        Set sh = Sheets(arr2(i))
        With sh
            .PageSetup.PrintArea = .Range(arr3(i)).Address
            Debug.Print .Range(arr3(i)).Address
        End With
    Next i
    Sheets(arr2).Select
    Debug.Print Sheets(arr2).Select
    
    
    'Save a range as PDF
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    saveLocation, Quality:=xlQualityStandard, _
    IgnorePrintAreas:=False, OpenAfterPublish:= _
    False
    If boolHide Then ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetHidden
    If boolProt Then ActiveWorkbook.Sheets(arrSplit(0)).Protect "4321"
      
      
    ActiveWorkbook.Protect "4321"
End Sub

---

不要忘记调整打印区域，以免出现空白页：