Sub Main()
Const DestFile As String = "MergedFile.pdf"
Dim MyPath As String, MyFiles As String
Dim a As Variant, i As Long, f As String
' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A1") ' or wherever; doesn't matter
Set fso = CreateObject("Scripting.FileSystemObject")
f = Dir(MyPath & "*.pdf")
While Len(f)
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
f = Dir()
Wend
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
If iFil Then a = Application.Transpose(Rng.Resize(iFil, 1))
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
MyFiles = Join(a, ",")
Application.StatusBar = "Merging, please wait ..."
Call MergePDFs(MyPath, MyFiles, DestFile)
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
End Sub
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
' Reference required: VBE - Tools - References - Acrobat
Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))
On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & Trim(a(i))) = "" Then
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If
exit_:
' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If
' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing
End Sub
Sub Main()
Const DestFile As String = "MergedFile"
Dim MyPath As String, MyFiles As String
Dim a As Variant, i As Long, f As String
Dim FileIdx
FileIdx = 1
' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A1") ' or wherever; doesn't matter
Set fso = CreateObject("Scripting.FileSystemObject")
For Each Item In Array("ABCRDF", "ABCOSD")
iFil = 0
f = Dir(MyPath & "*" & Item & ".pdf")
While Len(f)
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
f = Dir()
Wend
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
If iFil Then a = Application.Transpose(Rng.Resize(iFil, 1))
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
MyFiles = Join(a, ",")
Application.StatusBar = "Merging, please wait ..."
Call MergePDFs(MyPath, MyFiles, DestFile & FileIdx & ".pdf")
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
Next
End Sub
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
' Reference required: VBE - Tools - References - Acrobat
Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))
On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & Trim(a(i))) = "" Then
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If
exit_:
' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If
' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing
End Sub
Sub Main()
Const DestFile As String = "MergedFile"
Dim MyPath As String, MyFiles As String
Dim a As Variant, i As Long, f As String
Dim FileIdx
' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A1") ' or wherever; doesn't matter
Set fso = CreateObject("Scripting.FileSystemObject")
For Each Item In Array("ABCRDF", "ABCOSD")
f = Dir(MyPath & "*" & Item & ".pdf")
While Len(f)
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
f = Dir()
Wend
If iFil Then
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
a = Application.Transpose(Rng.Resize(1, 1))
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
If iFil = 1 Then
MyFiles = a
Else
MyFiles = Join(a, ",")
End If
Application.StatusBar = "Merging, please wait ..."
FileIdx = FileIdx + 1
Call MergePDFs(MyPath, MyFiles, DestFile & FileIdx & ".pdf")
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
Next
End Sub
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
' Reference required: VBE - Tools - References - Acrobat
Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))
On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & Trim(a(i))) = "" Then
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If
exit_:
' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If
' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing
End Sub
Sub Main()
Const DestFile As String = "MergedFile"
Dim MyPath As String, MyFiles As String
Dim a As Variant, i As Long, f As String
Dim FileIdx
' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each Item In Array("ABCRDF", "ABCOSD")
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A1") ' or wherever; doesn't matter
f = Dir(MyPath & "*" & Item & ".pdf")
While Len(f)
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
f = Dir()
Wend
If iFil Then
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
a = Application.Transpose(Rng.Resize(iFil, 1))
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
If iFil = 1 Then
MyFiles = a
Else
MyFiles = Join(a, ",")
End If
Application.StatusBar = "Merging, please wait ..."
FileIdx = FileIdx + 1
Call MergePDFs(MyPath, MyFiles, DestFile & FileIdx & ".pdf")
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
Next
End Sub
EDITED Corrected
Sub Main()
Const DestFile As String = "MergedFile"
Dim MyPath As String, MyFiles As String
Dim a As Variant, i As Long, f As String
Dim FileIdx
' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each Item In Array("ABCRDF", "ABCOSD")
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A1") ' or wherever; doesn't matter
iFil = 0
f = Dir(MyPath & "*" & Item & ".pdf")
While Len(f)
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
f = Dir()
Wend
If iFil Then
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
a = Application.Transpose(Rng.Resize(iFil, 1))
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
If iFil = 1 Then
MyFiles = a
Else
MyFiles = Join(a, ",")
End If
Application.StatusBar = "Merging, please wait ..."
FileIdx = FileIdx + 1
Call MergePDFs(MyPath, MyFiles, DestFile & FileIdx & ".pdf")
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
Next
End Sub
on which file is the "Â Cannot Insert pages of input folder path" error
Sub Main()
Const DestFile As String = "MergedFile"
Dim MyPath As String, MyFiles As String
Dim a As Variant, i As Long, f As String
Dim FileIdx
' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A" & Rows.Count).End(xlUp).Offset(1) ' or wherever; doesn't matter
For Each Item In Array("1", ")")
f = Dir(MyPath & "*" & Item & ".pdf")
While Len(f)
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
f = Dir()
Wend
Next
If iFil Then
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
a = Application.Transpose(Rng.Resize(iFil, 1))
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
If iFil = 1 Then
MyFiles = a
Else
MyFiles = Join(a, ",")
End If
Application.StatusBar = "Merging, please wait ..."
FileIdx = FileIdx + 1
Call MergePDFs(MyPath, MyFiles, DestFile & FileIdx & ".pdf")
Application.StatusBar = False
End If
iFil = 0
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A1") ' or wherever; doesn't matter
f = Dir(MyPath & "*.pdf")
While Len(f)
mtch = Application.Match(f, a, 0)
If IsError(mtch) Then
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
End If
f = Dir()
Wend
If iFil Then
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
a1 = Application.Transpose(Rng.Resize(iFil, 1))
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
If iFil = 1 Then
MyFiles = a1
Else
MyFiles = Join(a1, ",")
End If
Application.StatusBar = "Merging, please wait ..."
FileIdx = FileIdx + 1
Call MergePDFs(MyPath, MyFiles, DestFile & FileIdx & ".pdf")
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
End Sub
Sub Main()
Const DestFile As String = "MergedFile"
Dim MyPath As String, MyFiles As String
Dim a As Variant, i As Long, f As String
Dim FileIdx
' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
'.InitialFileName = "C:\Temp\"
.AllowMultiSelect = False
If .Show = False Then Exit Sub
MyPath = .SelectedItems(1)
DoEvents
End With
' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A" & Rows.Count).End(xlUp).Offset(1) ' or wherever; doesn't matter
For Each Item In Array("ABCRDF", "ABCOSD")
f = Dir(MyPath & "*" & Item & ".pdf")
While Len(f)
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
f = Dir()
Wend
Next
If iFil Then
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
a = Application.Transpose(Rng.Resize(iFil, 1))
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
If iFil = 1 Then
MyFiles = a
Else
MyFiles = Join(a, ",")
End If
Application.StatusBar = "Merging, please wait ..."
FileIdx = FileIdx + 1
Call MergePDFs(MyPath, MyFiles, DestFile & FileIdx & ".pdf")
Application.StatusBar = False
End If
iFil = 0
Set sh = Workbooks.Add.Sheets(1)
Set Rng = sh.Range("A1") ' or wherever; doesn't matter
f = Dir(MyPath & "*.pdf")
While Len(f)
mtch = Application.Match(f, a, 0)
If IsError(mtch) Then
iFil = iFil + 1
Set fsofile = fso.getfile(MyPath & f)
With Rng.Cells(iFil, 1)
.Value = fsofile.Name
.Offset(0, 1).Value = fsofile.DateLastModified
End With
End If
f = Dir()
Wend
If iFil Then
With sh.Sort
.SortFields.Add Key:=Rng.Offset(0, 1).Resize(iFil, 1), Order:=xlAscending
.SetRange Rng.Resize(iFil, 2)
.Apply
End With
a1 = Application.Transpose(Rng.Resize(iFil, 1))
End If
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
' Merge PDFs
If iFil Then
If iFil = 1 Then
MyFiles = a1
Else
MyFiles = Join(a1, ",")
End If
Application.StatusBar = "Merging, please wait ..."
FileIdx = FileIdx + 1
Call MergePDFs(MyPath, MyFiles, DestFile & FileIdx & ".pdf")
Application.StatusBar = False
Else
MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
End If
End Sub
Pls try
Open in new window
Regards