将同一 Excel 页面的多个版本复制到一个 PDF 中

Question

我有一个单页 excel 文件，它会根据下拉选择进行更改。我需要能够将每个数据集导出为一个 PDF。所以，我正在寻找一个宏，它可以遍历下拉菜单中的每个选择，并将每个数据集保存到一个多页 PDF 文件中。

我的想法是创建循环并将每个版本保存为临时工作表。然后我可以使用

ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")).Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "C:\tempo.pdf", Quality:= xlQualityStandard, IncludeDocProperties:=True, _
     IgnorePrintAreas:=False, OpenAfterPublish:=True

将所有工作表保存为一个 PDF，但我需要删除所有临时文件。

谢谢， 克里斯

Answer 1

我建议将它们全部单独导出为 PDF 到临时目录中，使用 Adob​​e 的 COM 自动化库（假设您有 Pro）将它们拼接在一起，然后删除临时文件夹。

Public Sub JoinPDF_Folder(ByVal strFolderPath As String, ByVal strOutputFileName As String)
On Error GoTo ErrHandler:

    Dim AcroExchPDDoc As Object, _
        AcroExchInsertPDDoc As Object
    Dim strFileName As String
    Dim iNumberOfPagesToInsert As Integer, _
        iLastPage As Integer
    Set AcroExchPDDoc = CreateObject("AcroExch.PDDoc")

    Dim strFirstPDF As String

' Get the first pdf file in the directory
    strFileName = Dir(strFolderPath + "*.pdf", vbNormal)
    strFirstPDF = strFileName

' Open the first file in the directory
    If Not (AcroExchPDDoc.Open(strFolderPath & strFileName)) Then
        Err.Raise 55555, "JoinPDF_Folder", "Could not open PDF for joining"
    End If

' Get the name of the next file in the directory [if any]
    If strFileName <> "" Then
        strFileName = Dir

    ' Start the loop.
        Do While strFileName <> ""

    ' Get the total pages less one for the last page num [zero based]
            iLastPage = AcroExchPDDoc.GetNumPages - 1
            Set AcroExchInsertPDDoc = CreateObject("AcroExch.PDDoc")

        ' Open the file to insert
            If Not (AcroExchInsertPDDoc.Open(strFolderPath & strFileName)) Then
                Err.Raise 55555, "JoinPDF_Folder", "Could not open PDF for joining"
            End If

        ' Get the number of pages to insert
            iNumberOfPagesToInsert = AcroExchInsertPDDoc.GetNumPages

        ' Insert the pages
            AcroExchPDDoc.InsertPages iLastPage, AcroExchInsertPDDoc, 0, iNumberOfPagesToInsert, True

        ' Close the document
            AcroExchInsertPDDoc.Close

        ' Delete the document
            Kill strFolderPath & strFileName

        ' Get the name of the next file in the directory
            strFileName = Dir
        Loop

    ' Save the entire document as the strOutputFileName using SaveFull [0x0001 = &H1]
        If Not (AcroExchPDDoc.Save(PDSaveFull, strOutputFileName)) Then
            Err.Raise 55556, "JoinPDF_Folder", "Could not save joined PDF"
        End If
    End If

    ' Close the PDDoc
    AcroExchPDDoc.Close

    Kill strFolderPath & strFirstPDF
    CallStack.Pop
    Exit Sub

ErrHandler:
    GlobalErrHandler
End Sub

Answer 2

这是我的解决方案：

Sub LoopThroughDD()

'Created by Chrismas007 

Dim DDLCount As Long
    Dim TotalDDL As Long
    Dim CurrentStr As String
    TotalDDL = Sheets("Report").DropDowns("Drop Down 10").ListCount

 'Loops through DropDown stores
    For DDLCount = 1 To TotalDDL
        Sheets("Report").DropDowns("Drop Down 10").Value = DDLCount
    CurrentStr = "Report" & DDLCount
'Creates a copy of each store and pastes them in a new worksheet
    Sheets.Add(After:=Sheets(Worksheets.Count)).Name = "Report" & DDLCount
    Sheets("Report").Columns("D:V").Copy
    Sheets(CurrentStr).Columns("A:S").Insert Shift:=xlToRight
    Sheets(CurrentStr).Range("A1:S98").Select
    Selection.Copy
    Sheets(CurrentStr).Range("A1:S98").Select
    Selection.PasteSpecial Paste:=xlPasteValues, _
    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Sheets(CurrentStr).PageSetup.PrintArea = "$A$1:$S$98"
'Sets worksheet to one page
    With Sheets(CurrentStr).PageSetup
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .Zoom = False
        .CenterHorizontally = True
        .CenterVertically = True
        End With
    Next DDLCount
'Because only visable worksheets will be captured on PDF dump, need to hide temporarily
    Sheets("Report").Visible = False

    Dim TheOS As String
    Dim dd As DropDown

'Going to name the file as the rep name so grabbing that info here
    Set dd = Sheets("Report").DropDowns("Drop Down 2")

    TheOS = Application.OperatingSystem

'Select all visible worksheets and export to PDF
    Dim ws As Worksheet
        For Each ws In Sheets
        If ws.Visible Then ws.Select (False)
    Next

    If InStr(1, TheOS, "Windows") > 0 Then
      ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    ThisWorkbook.Path & "\" & dd.List(dd.ListIndex), Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
                    False

    Else
      ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    ThisWorkbook.Path & ":" & dd.List(dd.ListIndex), Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
                    False
       End If

'Unhide our original worksheet
    Sheets("Report").Visible = True

    TotalDDL = Sheets("Report").DropDowns("Drop Down 10").ListCount

'Delete all temp worksheets
    For DDLCount = 1 To TotalDDL
        CurrentStr = "Report" & DDLCount
        Application.DisplayAlerts = False
        Sheets(CurrentStr).Delete
        Application.DisplayAlerts = True
    Next DDLCount



    DDLCount = Empty
End Sub