将同一个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

这里是我的解决办法：

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 

Answer 2

我建议单独导出他们所有PDF到一个临时目录，将它们订在一起使用Adobe的COM自动化库（假设你有专业版），然后删除临时文件夹。

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