使用Excel VBA和Adobe Acrobat库合并PDF时如何在空白单元格处停止

如何解决使用Excel VBA和Adobe Acrobat库合并PDF时如何在空白单元格处停止

首先，我想以说我有不到一周的使用VBA的经验来对此做个开头。

我一直试图创建一个脚本，以合并在Excel工作表中链接的PDF。我拥有的代码工作正常，但是，当我添加由空行分隔的多个表时，脚本将继续在空单元格中向下移动，并从下一个表中收集PDF。

因此，如果我选择最下面的表进行合并，则可以正常工作，但是如果我选择最上面的表，则将合并所有向下移动的表的所有链接的PDF。

这是我目前拥有的Excel工作表的屏幕截图： Excel Sheet

我想让脚本在向下移动D列时在遇到的第一个空单元格处停止，而不是继续到最后一个填充的单元格。这意味着该脚本将仅合并一张PDF表。

正如我所说，这是我使用VBA的第一周，因此我一直在努力使PDF合并的范围在遇到空白单元格时结束。

任何帮助将不胜感激！

Sub Button9_Click()

'References
'Adobe Acrobat 10.0 Type Library


    Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
    Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
    Dim PDFfiles As Range,PDFfile As Range
    Dim n As Long
    Dim em As String

        
    'Set start point of cell range
    'Takes ActiveCell from search results and offsets to filepaths
    
    'CURRENTLY LOOKS FOR LAST POPULATED CELL IN COLUMN,disREGARDING PREVIoUS EMPTY CELLS
    
        With ActiveSheet
            Set PDFfiles = .Range(ActiveCell.Offset(3,1),.Cells(.Rows.Count,"D").End(xlUp))
            
        End With
    
    'Create Acrobat API objects
    
        Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
        Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
    
    'Open first PDF file and merge other PDF files into it
    
        n = 0
        For Each PDFfile In PDFfiles
            n = n + 1
            If n = 1 Then
                objCAcroPDDocDestination.Open PDFfile.Value
            Else
                objCAcroPDDocSource.Open PDFfile.Value
                If Not objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1,objCAcroPDDocSource,objCAcroPDDocSource.GetNumPages,0) Then
                    MsgBox "Error merging" & PDFfile.Value
                End If
                objCAcroPDDocSource.Close
            End If
        Next
        
    
    'Save merged PDF files as a new file
    
        objCAcroPDDocDestination.Save 1,"C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"
        objCAcroPDDocDestination.Close
    
        Set objCAcroPDDocSource = nothing
        Set objCAcroPDDocDestination = nothing

    'Opens dialogue Box for successful/Failed merge
    
        MsgBox "Created New PDF (" & Sheets("SEARCH").Range("E6").Value & ")" & vbCrLf & vbCrLf & "File Path: C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"
    
    'Opens merged PDF
    
        ActiveWorkbook.FollowHyperlink "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"

    

End Sub

解决方法

请尝试下一个代码，

Sub MergePDFDocuments()
 'References to 'Adobe Acrobat 10.0 Type Library
    Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc,objCAcroPDDocSource As Acrobat.CAcroPDDoc,i As Long
    Dim PDFfiles As Range,PDFfile As Range,n As Long,em As String,processArr As String,prRng As Range
    Dim sh As Worksheet,startRow As Long,endRow As Long
    
    Set sh = ActiveSheet 'use here your sheet
    processArr = "A" 'the group files to be processed.
                     'It can be "B",or other letter if the workbook will be filled with other groups
    'CURRENTLY LOOKS FOR LAST POPULATED CELL IN COLUMN,DISREGARDING PREVIOUS EMPTY CELLS
    'Set PDFfiles = sh.Range(sh.Offset(3,1),sh.cells(rows.count,"D").End(xlUp))
    endRow = sh.cells(rows.count,"D").End(xlUp).row
    For i = 2 To endRow
        If sh.Range("C" & i).value = "PRODUCT " & processArr Then
            startRow = i + 2: Exit For
        End If
    Next i
    If startRow >= i Then MsgBox "Strange..." & vbCrLf & _
                     "The area to be prcessed ""PRODUCT " & processArr & """ could not be found.": Exit Sub
   
    'Create Acrobat API objects
    Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
    Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
    
    'Open first PDF file and merge other PDF files into it
    For i = startRow To endRow
        n = n + 1
        If sh.Range("D" & i).value = "" Then Exit For 'iteration is interrupted in case of an empty cell in D:D:
        If n = 1 Then
            objCAcroPDDocDestination.Open sh.Range("D" & i).value
        Else
            objCAcroPDDocSource.Open sh.Range("D" & i).value
            If Not objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1,_
                                        objCAcroPDDocSource,objCAcroPDDocSource.GetNumPages,0) Then
                MsgBox "Error merging: " & sh.Range("D" & i).value
            End If
            objCAcroPDDocSource.Close
        End If
    Next i
            
    'Save merged PDF files as a new file. Here the pdf name can be assorted with the area to be processed (for instance PRODUCT A):
    objCAcroPDDocDestination.Save 1,"C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
    objCAcroPDDocDestination.Close
    
    Set objCAcroPDDocSource = Nothing
    Set objCAcroPDDocDestination = Nothing

    'Opens dialogue box for successful/failed merge
    MsgBox "Created New PDF (" & Sheets("SEARCH").Range("E6").value & ")" & vbCrLf & vbCrLf & "File Path: C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
    
    'Opens merged PDF
    ActiveWorkbook.FollowHyperlink "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
End Sub

您必须将processArr设置为要处理（图片中的A或B）。

代码未经测试，但可以正常工作。请对其进行测试并发送一些反馈。