VBA，如果文件名>1，则追加Pdfs

Question

我有一个vba代码，导出excel表格为pdf的文件名为基础。如果"File Name“是相同的，我想将pdf附加到一个文件中。即。图纸2和图纸3将位于一个名为Overflow的文件中。

​

​

我目前的代码不附加，它只做单个pdf页面。有没有办法做一些IF语句where file Name >1，然后将它们附加到一个pdf文件中？

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

Answer 1

太棒了。您的问题可以使用面向对象的方法来解决。在单独的类模块中，让我们创建一个类(假设将其命名为"clsExportPosition")。这个类应该包含两个属性：

1. "DestinationFile“-包含从属于此pdf文件的相应pdf-file.
2. "TargetWorksheets”工作表名称集合的完整路径。

这个类模块的代码清单如下：

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

将此类模块以名称clsExportPosition保存在工作簿中。然后我们将重写代码，如下所示：

'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

就这样。只需将此代码粘贴到工作簿中的VB编辑器中，保存它并尝试使用。希望能有所帮助。