Trigger warning, the screen will flash each time a subfolder is processed using this method. If needed, I can code it to use another method. One flash is usually ok but many can be a problem for some people.
I marked lines in red that you can comment out to not do the merge but test it otherwise.
I used Wells' pdfmerge() routine. I do not have Acrobat on this computer so I can not test the slight tweak that I did to it.
I think you wanted the merged pdf in each subfolder and another copy in another folder. If not, you can modify the lines in red. Obviously, you do need to change the values for the folders p and p2.
Sub IterateSubfolders()
Dim a, f, i As Long, j As Long, pdf As String, p As String, tf As Boolean
Dim p2 As String
'Parent folder
'p = ThisWorkbook.Path & "\"
p = "C:\Users\lenovo1\Dropbox\_Excel\pdf\Acrobat\"
'Folder to copy merged pdf to
p2 = p
'SubFolders Array
f = aFFs(p, "/ad", True)
'Merge pdfs in Parent folder, save copy there, and copy to p2 folder.
a = aFFs(p & "*.pdf")
If IsArray(a) Then
ReDim Preserve f(UBound(f) - 1)
j = j + 1
pdf = p & "PDF_" & j & ".pdf"
If MergePDF(a, pdf) Then FileCopy pdf, p2 & "PDF_" & j & ".pdf"
End If
'Merge pdfs in Subfolders, save merged file in subfolders,
'and copy merged pdf to p2 folder.
For i = 0 To UBound(f)
a = aFFs(f(i) & "\*.pdf")
If IsArray(a) Then
j = j + 1
pdf = f(i) & "PDF_" & j & ".pdf"
If MergePDF(a, pdf) Then FileCopy pdf, p2 & "PDF_" & j & ".pdf"
End If
Next i
End Sub
'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant
Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long
If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If
a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
'Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function
Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function
'https://wellsr.com/vba/2017/word/combine-pdfs-with-vba-and-adobe-acrobat/
'Private Function MergePDF(arrFiles() As String, strSaveAs As String) As Boolean
Private Function MergePDF(arrFiles, strSaveAs As String) As Boolean
'---------------------------------------------------------------------------------------------------
'---PROGRAM: MergePDFs------------------------------------------------------------------------------
'---DEVELOPER: Ryan Wells (wellsr.com)--------------------------------------------------------------
'---DATE: 09/2017-----------------------------------------------------------------------------------
'---DESCRIPTION: This function uses Adobe Acrobat (won't work with just the Reader!) to-------------
'--- combine PDFs into one PDF and save the new PDF with its own file name.-------------
'---INPUT: The function requires two arguments.-----------------------------------------------------
'--- 1) arrFiles is an array of strings containing the full path to each PDF you want to------
'--- combine in the order you want them combined.------------------------------------------
'--- 2) strSaveAs is a string containing the full path you want to save the new PDF as.-------
'---REQUIREMENTS: 1) Must add a reference to "Adobe Acrobat X.0 Type Library" or "Acrobat"----------
'--- under Tools > References. This has been tested with Acrobat 6.0 and 10.0.------
'---CAUTION: This function won't work unless you have the full Adobe Acrobat. In other words,-------
' Adobe Reader will not work.------------------------------------------------------------
'---------------------------------------------------------------------------------------------------
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim i As Integer
Dim iFailed As Integer
On Error GoTo NoAcrobat:
'Initialize the Acrobat objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles))) 'open the first file
'Open each subsequent PDF that you want to add to the original
'Open the source document that will be added to the destination
For i = LBound(arrFiles) + 1 To UBound(arrFiles)
objCAcroPDDocSource.Open (arrFiles(i))
If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MergePDF = True
Else
'failed to merge one of the PDFs
iFailed = iFailed + 1
End If
objCAcroPDDocSource.Close
Next i
objCAcroPDDocDestination.Save 1, strSaveAs 'Save it as a new name
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
NoAcrobat:
If iFailed <> 0 Then
MergePDF = False
End If
On Error GoTo 0
End Function