VBA, if file name > 1 then append Pdfs

Question

I have a vba code which exports excel sheets as pdf based on file name. I would like to append pdfs into one file if "File Name" is the same. Ie. Sheet 2 and Sheet 3 will be in one file called Overflow.

my current code doesnt append, it just does single pdf pages. Is there a way to do some IF statement where File Name > 1 then append them to one pdf file?

Sub CreatePDF_Button_Click()
    
    Dim SheetName As String
    With Worksheets("PDF Management")
        LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        
        For i = 2 To LastRow
            SheetName = .Cells(i, 1)
            Filename = .Cells(i, 2)
            Destination = .Cells(i, 3)
            Call CreatePDF(SheetName, Destination & Filename)
        Next
    End With
End Sub



Sub CreatePDF(PageName As String, PathName As String)

    ActiveWorkbook.Worksheets(PageName).ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=PathName, _
        quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
        
End Sub

Have a look at [this post](https://stackoverflow.com/questions/14404650/save-multiple-sheets-to-pdf). You could amend your approach slightly and use the code in that post — Zac, Jul 07 '20 at 13:29
Thanks, unsure how to put my two sheets into one array while keeping my format the same. — excelguy, Jul 07 '20 at 16:59

score 1 · Answer 1 · answered Jul 13 '20 at 06:56

excelguy. Your problem can be solved using object-oriented approach. In the separate class module let's create a class (let's say name it "clsExportPosition"). This class should contain two attributes:

"DestinationFile" - contains full path to appropriate pdf-file.
"TargetWorksheets" - collection of worksheet names affiliated to this pdf-file.

Code listing of this class module as follows:

Private pvtDestFile As String
    Public TargetWorksheets As New Collection

    Property Get DestinationFile() As String
          DestinationFile = pvtDestFile
    End Property

    Property Let DestinationFile(newValue As String)
          pvtDestFile = newValue
    End Property

    Public Sub AddTargetWorksheet(wrkShtName As String)
          TargetWorksheets.Add wrkShtName
    End Sub

Save this class module with name clsExportPosition in your workbook. Then we'll rewrite your code as follows:

'This is main routine which forms object collection. 
'Each object in this collection will contain pdf-filename (full path) in one 'attribute and list of affiliated worksheets in another attribute. Finally 
'this routine calls subroutine performing export to pdf format

Private Sub CreatePDF_Button_Click()
         Dim i As Long
         Dim ExportPositions As New Collection
         Dim LastRow As Long

         With ActiveWorkbook.Worksheets("PDF_Management")
             LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
             Call AddExpPosition(.Cells(2,1), .Cells(2,3) & "\" & .Cells(2,2), ExportPositions)
             For i=3 To LastRow
                  If IsDestAlreadyPresent(.Cells(i,3) & "\" & .Cells(i,2), ExportPositions) Then
                        Call AddSheetToList(.Cells(i,1),  .Cells(i,3) & "\" & .Cells(i,2), ExportPositions)
                  Else
                        Call AddExpPosition(.Cells(i,1),  .Cells(i,3), & "\" & .Cells(i,2), ExportPositions)
                  End If
              Next i
         End With
         Call CreatePDF(ExportPositions)
    End Sub

'== These are auxiliary subroutines and functions==
    Sub AddExpPosition(pgName As String, pthName As String, expCollection As Collection)
       Dim exPosition As New clsExportPosition

       exPosition.DestinationFile = pthName
       exPosition.AddTargetWorksheet(pgName)
       expCollection.Add exPosition
    End Sub

    Sub AddSheetToList (pgName As String, pthName As String, expCollection As Collection)
        For Each itm In expCollection
             If itm.DestinationFile = pthName Then
                   itm.AddTargetWorksheet(pgName)
             End If
       Next
    End Sub

    Function IsDestAlreadyPresent(pthName As String, expColl As Collection) As Boolean
         Dim result As Boolean

         result = False
          For Each itm In expColl
              If itm.DestinationFile = pthName Then
                      result = True
              End If
          Next itm
          IsDestAlreadyPresent = result
    End Function

    Function expCollToArr(expCollect As Collection) As Variant
         Dim result As Variant
         Dim cnt As Long

         ReDim result(expCollect.Count -1)
         For cnt = 0 To expCollect.Count - 1
              result(cnt) = expCollect(cnt +1)
         Next
         expCollToArr = result
    End Function

    Sub CreatePDF(expCollection As Collection)
          Dim destArr As Variant

          For Each expItem In expCollection
                destArr = expCollToArr(expItem.TargetWorksheets)
                ActiveWorkbook.Sheets(destArr).Select
                ActiveWorkbook.Worksheets(destArr).ExportAsFixedFormat Type := xlTypePDF,_
                Filename := expItem.DestinationFile,_ 
                ignoreprintareas := False,_ 
                openafterpublish := False
         Next
    End Sub

That's it. Just paste this code into VB editor in your workbook, save it and try to play with. Hope it helps.

VBA, if file name > 1 then append Pdfs

1 Answers1