Excel VBA，如果文件名>；1然后附加PDF

我有一个vba代码，它根据文件名将excel表格导出为pdf格式。如果“文件名”相同，我想将PDF附加到一个文件中。即，表2和表3将在一个名为Overflow的文件中

我当前的代码没有追加，它只添加单个pdf页面。 有没有办法在文件名大于1的情况下执行一些IF语句，然后将它们附加到一个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

---

好家伙。您的问题可以使用面向对象的方法来解决。 在单独的类模块中，让我们创建一个类（假设将其命名为“clsExportPosition”）。此类应包含两个属性：

“DestinationFile”-包含相应pdf文件的完整路径

“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

'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

在工作簿中保存名为clsExportPosition的类模块。然后我们将按如下方式重写您的代码：

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

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

看一看。你可以稍微修改一下你的方法，并使用那篇博文中的代码。谢谢，不知道如何在保持格式不变的情况下将我的两张纸放在一个数组中。