Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!
how to differentiate pdf files files in a folder by file name and merge into pdf files based on last modified date using VBA
According to my work,I have a folder which contains some pdf files.
1.I need to merge files into 2 separate files.(File names ends with ABCRDF & ABCOSD into single merged file and all other pdf files into another merged file.
2.So after merging we will have only 2 pdf files.One which contains file names ends with ABCRDF & ABCOSD.And other merged file with all files except above 2 files.
3.Merging should be done by last modified time stamp.
I have code which merge all the files present in a folder into a single pdf based last modified time stamp.It wont differentiate files based on file names.It will take all the files present and merge to a single pdf file.I will attach the same here.
Any help regarding this would be greatly appreciated..!!
1.I need to merge files into 2 separate files.(File names ends with ABCRDF & ABCOSD into single merged file and all other pdf files into another merged file.
2.So after merging we will have only 2 pdf files.One which contains file names ends with ABCRDF & ABCOSD.And other merged file with all files except above 2 files.
3.Merging should be done by last modified time stamp.
I have code which merge all the files present in a folder into a single pdf based last modified time stamp.It wont differentiate files based on file names.It will take all the files present and merge to a single pdf file.I will attach the same here.
Any help regarding this would be greatly appreciated..!!
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
Do more with
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Hi,
Pls try
Pls try
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")
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
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
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
Thank you for your response.
Actually both merged file names should be different for both files..In above only one dest file name is mentioned..Could you please help me on that also.
I am getting the below error while running the above code.
Actually both merged file names should be different for both files..In above only one dest file name is mentioned..Could you please help me on that also.
I am getting the below error while running the above code.
then try
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
then try
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
I tried with above code..now one resulted file is created name as mergedfile1.pdf which contains only one file which has high last modified timestamp among all ABCRDF and ABCOSD files.And the second resulted file is not get created also.
Ideally It should includes all the files which ends with ABCRDF and ABCOSD.But while running this code , now it is taking only one file (Which got created first ) among all the ABCRDF and ABCOSD files.
I am attaching the error also.
Ideally It should includes all the files which ends with ABCRDF and ABCOSD.But while running this code , now it is taking only one file (Which got created first ) among all the ABCRDF and ABCOSD files.
I am attaching the error also.
then try
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
Hi ,
Sorry for the late reply.
2 output files are getting created named as mergedFile1 and mergedFile2. But first merged file contains only one file, filename ends with ABCRDF(it's LastModifiedTime is most recent among all ABCRDF and ABCOSD files). Next output file contains again only one file which is having second least LastModifiedTime among all ABCRDF and ABCOSD files.Rest of the input files are not getting added to any of these 2 output files.
While running above code, First output file(MergedFile1) got created as explained above and after that dialogue box appeared saying " Cannot Insert pages of input folder path" .Then next output file(MergedFile2) got created.
Any help regarding this would be appreciated :-)
Sorry for the late reply.
2 output files are getting created named as mergedFile1 and mergedFile2. But first merged file contains only one file, filename ends with ABCRDF(it's LastModifiedTime is most recent among all ABCRDF and ABCOSD files). Next output file contains again only one file which is having second least LastModifiedTime among all ABCRDF and ABCOSD files.Rest of the input files are not getting added to any of these 2 output files.
While running above code, First output file(MergedFile1) got created as explained above and after that dialogue box appeared saying " Cannot Insert pages of input folder path" .Then next output file(MergedFile2) got created.
Any help regarding this would be appreciated :-)
then try
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
Hi,
Thanks for your assistance.
I tried with above code.Every files with ABCRDF file name combined and merged into one file and all files with ABCOSD merged into other file.
But our requirement is filename ends with both ABCRDF and ABCOSD should combine and merge into single file(MergedFile1).Rest of the files should combine into other output file(MergedFile2)
Thanks for your assistance.
I tried with above code.Every files with ABCRDF file name combined and merged into one file and all files with ABCOSD merged into other file.
But our requirement is filename ends with both ABCRDF and ABCOSD should combine and merge into single file(MergedFile1).Rest of the files should combine into other output file(MergedFile2)
then try
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
Now every file present in the folder is getting combined and merged into 2nd output file(MergedFile2). When debugging,I noticed ,for creating 2nd output file,it is taking MergedFile1 too(because it is getting created already and present in the same path).
1st Output file contain both files ends with ABCRDF and ABCOSD plus some more files present in the folder.
1st Output file contain both files ends with ABCRDF and ABCOSD plus some more files present in the folder.
then try
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
Hello All,
Good day...
I tried with above code..
1.Now output file 1(MergedFile1) contains all the files ends with ABCRDF and ABCOSD as expected.
2.But Merged file2 contains all the files present in the folder..While merging files,It is taking MergedFile1 also..As per our requirement,It should not take MergedFile1.
Good day...
I tried with above code..
1.Now output file 1(MergedFile1) contains all the files ends with ABCRDF and ABCOSD as expected.
2.But Merged file2 contains all the files present in the folder..While merging files,It is taking MergedFile1 also..As per our requirement,It should not take MergedFile1.
then try
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
If Not f Like "MergedFile*.pdf" 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
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
Premium Content
You need an Expert Office subscription to comment.Start Free Trial