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

Question

我有一个 vba 代码，可以根据文件名将 excel 工作表导出为 pdf。如果“文件名”相同，我想将 pdf 附加到一个文件中。 IE。 Sheet 2 和 Sheet 3 将在一个名为 Overflow 的文件中。

我当前的代码没有附加，它只是处理单个 pdf 页面。 有没有办法做一些 IF 语句，其中 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 文件的完整路径。
2. “TargetWorksheets” - 附属于该 pdf 文件的工作表名称的集合。

该类模块代码如下：

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 编辑器中，保存并尝试使用。希望对您有所帮助。