excel - 使用 Excel VBA 和 Adob​​e Acrobat 库合并 PDF 时如何在空单元格处停止

Question

首先，我想先说一下我使用 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, 0, 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

Answer 1

请尝试下一个代码:

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, 0, 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)。
代码未经测试，但它应该可以工作。请对其进行测试并发送一些反馈。