Копирование нескольких версий одной и той же страницы 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 в временную директорию, сшивая их вместе, используя библиотеку автоматизации COM компании Adobe (если у вас есть 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