Hi Ken
Not 100% sure to be honest as like I said the merge works fine, it's the output pdf file that has the order different to the order of the files in the folder. I suspect it's something to do with filesize, date modified etc.?? but regardless I need the merged files to just be merged in the same order as how they are listed inside each folder.
I've put the merge code below. Had to install some 3rd party software to get it work.
Sub iSubfolders()
Dim a, f, i As Long, p As String
Dim p2 As String, r As String, fso As Object
'Parent folder
p = ThisWorkbook.Path & ""
'p = "C:\Users\lenovo1\Dropbox\_Excel\pdf\Acrobat"
'Folder to copy merged pdfs in subfolders to, p2 initional, and r actual.
p2 = p & "MergedPDFs"
If Dir(p2, vbDirectory) = "" Then MkDir p2
'Make a new folder in p2 to store this run's merged pdf files.
'SubFolders Array
a = aFiles(p, "/ad", True)
Do
i = i + 1
r = p2 & "\Run" & i & ""
Loop Until Dir(r, vbDirectory) = ""
MkDir r
Set fso = CreateObject("Scripting.FileSystemObject")
'SubFolders Array
f = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & p & """" & " /ad/b/s").StdOut.ReadAll, vbCrLf)
'Add parent folder to f:
f(UBound(f)) = Left(p, Len(p) - 1)
'Merge pdfs in subfolders, save merged file in r folder with subfolder's name.pdf.
For i = 0 To UBound(f)
a = aFiles(f(i) & "", "*.pdf", False)
If a(1) <> "" And InStr(f(i), p2) = 0 Then
pdftkMerge a, r & fso.GetFolder(f(i)).Name & ".pdf" 'Acrobat
'PDFCreatorCombine a, r & fso.GetFolder(f(i)).Name & ".pdf" 'PDFCreator
'pdftkMerge a, r & fso.GetFolder(f(i)).Name & ".pdf" 'pdftk
End If
Next i
Set fso = Nothing
MsgBox "PDF files merged to folder: " & r
End Sub
'https://www.pdflabs.com/tools/pdftk-the-pdf-toolkit/
Sub pdftkMerge(arrayPDFs, pdfOut As String)
Dim a, i As Long
a = arrayPDFs
For i = LBound(a) To UBound(a)
a(i) = """" & a(i) & """"
Next i
'Command line options, https://www.pdflabs.com/docs/pdftk-man-page/
'8191 character limit length for command line string.
'Not sure what limit pdftk has, same probably.
Shell "pdftk " & Join(a, " ") & " cat output " & """" & pdfOut & """", vbHide
End Sub
'Similar to: NateO's code, http://www.mrexcel.com/forum/showpos...68&postcount=2
Function aFiles(strDir As String, searchTerm As String, _
Optional SubFolders As Boolean = True)
Dim fso As Object
Dim strName As String
Dim i As Long
ReDim strArr(1 To Rows.Count)
'strDir must not have a trailing \ for subFolders=True
If Right(strDir, 1) <> "" Then strDir = strDir & ""
'Exit if strDir does not exist
If Dir(strDir, vbDirectory) = "" Then Exit Function
Let strName = Dir$(strDir & searchTerm)
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i) = strDir & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
'Strip trailing \ if subFolders=False
If SubFolders = False Then strDir = Left(strDir, Len(strDir) - 1)
Call recurseSubFolders(fso.GetFolder(strDir), strArr, i, searchTerm)
Set fso = Nothing
If i = 0 Then i = 1 'Returns one empty array element in strArr
ReDim Preserve strArr(1 To i)
aFiles = strArr
End Function
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr, _
ByRef i As Long, _
ByRef searchTerm As String)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "" & searchTerm)
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i) = SubFolder.Path & "" & strName
Let strName = Dir$()
Loop
recurseSubFolders SubFolder, strArr, i, searchTerm
Next
End Sub
Thanks for your help