Solved Run 6 VBA macros at once for all excel files in a directory

AlwaysWillingToLearn November 30, 2015 at 00:31:07

Not too sure what you mean, but if you explain with more detail perhaps we can help. What does the macro do? are all six of these in the same workbook? when you say how can i run all those for all the excel (xlsm,xlsx,xlsb) files in a directory What exactly do you mean? The more info you give us the easier it is to help

OK sorry about not being very clear. we receive about 300 excel files (in xlsb format). here are the steps that i need to do and will also mention for which macros are developed. 1. Un protects all the 300 files (different passwords for different files)- macro created 2.put a filter by current month in specific cells-macro created 3.Format-macro created 4-update a cell with previous month - unable to create macro as the cell is protected 5-create pdf files fo excel-macro created 6-combine pdfs based on file name - unable to create macro what i am looking for is how can i run the above macros on all the files and sub folder in a directory

AlwaysWillingToLearn November 30, 2015 at 04:19:27

Here is some code i wrote ages ago, what this does is: 1) Asks you to browse to a folder where your files are kept 2) It will then load each file and display its name in the debug window You will need to add your code where i have commented out below so that your macros are called for each file loaded. NOTE: You will need to reference 'Microsoft scripting runtime' Tools >> References >> 'Microsoft scripting runtime' run the code as is first so that you can see how it works then try to integrate your code into it, hopefully its not going to be too difficukt to understand. Run it from Sub LoadFiles.... All this does is loop through all the files within a given folder and subfolders and displays the filenames in the debug window.. Sub LoadFiles() ListFilesInFolder BrowseForFolder, True End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'Function purpose: To Browser for a user selected folder. 'If the "OpenAt" path is provided, open the browser at that directory 'NOTE: If invalid, it will open at the Desktop level Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files 'ADD YOUR CODE HERE TO DO WHATEVER YOU WANT IT TO ON EACH FILE Debug.Print FileItem.Name Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub message edited by AlwaysWillingToLearn

it is giving me an error "Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)" at this line. i have also enabled scripting runtime

AlwaysWillingToLearn December 1, 2015 at 00:06:06

Can you tell us exactly what error you are getting? what version of office are you using? iv just copied the code in to excel and tested and its working correctly for me.

I am using office 2010 here is the code that you have given and i have included my macros in the place that you have mentioned it gives a pop up which says "Compile error User-defined type not defined" at the line "Sub ListFileslnFolderCSourceFolderNaxne As String, IncludeSubfolders As Boolean)" Sub LoadFiles() ListFilesInFolder BrowseForFolder, True End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'Function purpose: To Browser for a user selected folder. 'If the "OpenAt" path is provided, open the browser at that directory 'NOTE: If invalid, it will open at the Desktop level Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files 'ADD YOUR CODE HERE TO DO WHATEVER YOU WANT IT TO ON EACH FILE Sub FilterAllSheets() Dim Sh As Worksheet Dim myRange As Range For Each Sh In ActiveWorkbook.Worksheets Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" End With Next MsgBox "Done.", vbInformation End Sub Sub createPDFfiles() Dim ws As Worksheet Dim try As String For Each ws In ActiveWorkbook.Worksheets On Error Resume Next try = ws.Cells(3, 5) ' try = "c:\" & ws.Cells(3, 5) Set AtoK = ws.Range(ws.Range("A1:J1537"), ws.Range("K" & Cells.Rows.Count).End(xlUp)) AtoK.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=try, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False Next ws End Sub Debug.Print FileItem.Name Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub

AlwaysWillingToLearn December 1, 2015 at 01:44:15

Ok, i see the issues, you have put a sub within a sub, you cannot do that, plus your code will need to be changed in order to working with my code. let me have a play.

AlwaysWillingToLearn December 1, 2015 at 02:29:20

I have modified the code so now it incorporates the Autofilter sub and the creatPDF, the issue is i dont know how your auto filter works so cannot test that, it seems to throw and error for me on the following line .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic But it may still work for you.. One question i have, when you create the PDF with your code, does it automatically save it or are you prompted to save it somewhere? Here is the code Dim iExcel As Object Sub LoadFiles() ListFilesInFolder BrowseForFolder, True End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'Function purpose: To Browser for a user selected folder. 'If the "OpenAt" path is provided, open the browser at that directory 'NOTE: If invalid, it will open at the Desktop level Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Set iExcel = CreateObject("Excel.Application") Let iExcel.Visible = True iExcel.Workbooks.Open (FileItem.Path) Dim Sh As Worksheet Dim myRange As Range Dim ws As Worksheet Dim try As String For Each Sh In iExcel.Worksheets Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" End With On Error Resume Next try = ws.Cells(3, 5) Set AtoK = ws.Range(ws.Range("A1:J1537"), ws.Range("K" & Cells.Rows.Count).End(xlUp)) AtoK.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=try, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False iExcel.DisplayAlerts = False iExcel.ActiveWorkbook.CheckCompatibility = False iExcel.ActiveWorkbook.Save iExcel.ActiveWorkbook.Close iExcel.Quit iExcel.DisplayAlerts = True Next Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing End Sub message edited by AlwaysWillingToLearn

AlwaysWillingToLearn December 1, 2015 at 03:21:34

I have changed your code for saving each sheet as PDF, i dont know what your code was doing or if it worked, but i have updated it anyways.... also i am not sure what Atok was meant to be doing so i have removed it, try this, if it works great otherwise you can include Atok again by uncommenting it. Dim iExcel As Object Sub LoadFiles() ListFilesInFolder BrowseForFolder, True End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'Function purpose: To Browser for a user selected folder. 'If the "OpenAt" path is provided, open the browser at that directory 'NOTE: If invalid, it will open at the Desktop level Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Set iExcel = CreateObject("Excel.Application") Let iExcel.Visible = True iExcel.Workbooks.Open (FileItem.Path) Dim Sh As Worksheet Dim myRange As Range Dim ws As Worksheet Dim Strtry As String Dim Atok For Each Sh In iExcel.Worksheets Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" End With ' On Error Resume Next For Each ws In iExcel.Worksheets Strtry = ws.Cells(3, 5) ' Set Atok = ws.Range(ws.Range("A1:J1537"), ws.Range("K" & Cells.Rows.Count).End(xlUp)) iExcel.ActiveWorkbook.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:="C:\" & Strtry & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False Next ws iExcel.DisplayAlerts = False iExcel.ActiveWorkbook.CheckCompatibility = False iExcel.ActiveWorkbook.Save iExcel.ActiveWorkbook.Close iExcel.Quit iExcel.DisplayAlerts = True Next Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing Set iExcel = Nothing End Sub

Hi AlwaysWillingToLearn I can see the code is actually opening all the files and performing macros. however when i try to filter it is not happening on all the sheets secondly could you also help me in creating pdf files rather than Range("A1:J1537") to the row when it find the words as "INVOICE TOTAL" in colum "I" for example if i have invoice total in cell :"I1545" it have to print from ("A1:J1545") thanks a lot for your help and quick responses

AlwaysWillingToLearn December 1, 2015 at 04:31:18

It looks like i will need to rewrite some of your code, let me work on it.

Thanks a lot. not sure if i can ask this. is there a way i can contact you over the phone?

AlwaysWillingToLearn December 1, 2015 at 05:40:23

Hi oodai, Sorry unforunatly i wont be able to speak with you as i am at work, also it is best we keep the discussion here so that everyone can benefit from the progress and code. Updates: The code now goes through column I and looks for the word "Invoice Created" it then uses the range A1 to J (and where every Invoice Created was found) and creates PDFs for each sheet. i am still unsure as to what you autofilter is doing, can you explain? or provide some dummy data so i can recreate it on my side....

sure. I will try and explain as detail as possible. Input: 1. We receive excel files (xlsb) files from different people which are password protected to edit (not a common password). 2. the file contains multiple sheets Process: 1. what we have to do is unprotect all the files and sheets 2. for sheets (tabs) which are colored light blue filter column A with last month from dropdown and Column I with Non-Zeros 3.copy data from A1:J( row is dynamic till the row we find "INVOICE TOTAL") 4. Create pdf (for all the worksheets with light blue color) filename will be cell "E3" 5. once pdf is created this has to be combined with another file which has the same file name. there ends my process what i am looking for one macro which loops throguh all the files and perform below actions 1. unprotect all the files 2.create filter with lastmont in column and nonzero in coloum J for all the light blue colored tabs 3. Create pdf files for blue colored tabs 4. merge pdf based on file name below is the code that i have which i got it from experts like you to Unprotect all the files: Const cStartFolder = "C:\Users\New folder" 'no slash at end Const cFileFilter = "*.xlsb" Const cPassword1 = "123" 'use empty quotes if blank Sub UnprotectAllWorksheets() Dim i As Long, j As Long, arr() As String, wkb As Workbook, wks As Worksheet ExtractFolder cStartFolder, arr() On Error Resume Next j = -1: j = UBound(arr) On Error GoTo 0 For i = 0 To j Set wkb = Workbooks.Open(arr(i), False) For Each wks In wkb.Worksheets On Error Resume Next wks.Unprotect cPassword1 wks.Unprotect cPassword2 On Error GoTo 0 Next wkb.Save wkb.Close Next End Sub Sub ExtractFolder(Folder As String, arr() As String) Dim i As Long, objFS As Object, objFolder As Object, obj As Object Set objFS = CreateObject("Scripting.FileSystemObject") Set objFolder = objFS.GetFolder(Folder) For Each obj In objFolder.SubFolders ExtractFolder obj.Path, arr() Next For Each obj In objFolder.Files If obj.Name Like cFileFilter Then On Error Resume Next i = 0: i = UBound(arr) + 1 On Error GoTo 0 ReDim Preserve arr(i) arr(i) = objFolder.Path & Application.PathSeparator & obj.Name End If Next End Sub for filtering: Sub FilterAllSheets() Dim Sh As Worksheet Dim myRange As Range For Each Sh In ActiveWorkbook.Worksheets Set myRange = Sh.Range("A10", Sh.Range("J10").End(xlDown)) With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" End With Next MsgBox "Done.", vbInformation End Sub for creating pdfs Sub createPDFfiles() Dim ws As Worksheet Dim try As String For Each ws In ActiveWorkbook.Worksheets On Error Resume Next try = ws.Cells(3, 5) ' try = “c:\” & ws.Cells(3, 5) Set AtoK = ws.Range(ws.Range("A1:J1537"), ws.Range("K" & Cells.Rows.Count).End(xlUp)) AtoK.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=try, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False Next ws End Sub please help me to run these codes for all the files and sheets with one macro.

AlwaysWillingToLearn December 1, 2015 at 06:29:30

OK, i have updated the code, it seems to work for me, however you will need to test it... Question: If the passwords are not common how to do you go about unprotecting them? NOTE: Please change the destination path from "C:\" to where ever you wish for the pdfs to be saved. Please try this code: NOTE: I have not yet coded the unprotect password procedure until i know how you go about unprotecting the sheets, is it manual or via code? Dim iExcel As Object Private Sub LoadFiles() ListFilesInFolder "P:\Scratch\crap\", True End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Set iExcel = CreateObject("Excel.Application") Let iExcel.Visible = False iExcel.Workbooks.Open (FileItem.Path) Dim Sh As Worksheet Dim myRange As Range Dim ws As Worksheet Dim Strtry As String Dim Atok As Range Dim LR For Each Sh In iExcel.Worksheets Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) ' Auto Filter With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" End With ' Creates PDF LR = Sh.Range("I" & Rows.Count).End(xlUp).Row For i = 1 To LR If Sh.Cells(i, 9) = "Invoice Created" Then Sh.PageSetup.Orientation = xlLandscape Sh.Range("A1:J" & i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ "C:\" & Sh.Range("E3") & ".pdf", Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Exit For End If Next i Next Sh iExcel.DisplayAlerts = False iExcel.ActiveWorkbook.CheckCompatibility = False 'iExcel.ActiveWorkbook.Save iExcel.ActiveWorkbook.Close iExcel.Quit iExcel.DisplayAlerts = True Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If 'Clean up Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing Set iExcel = Nothing End Sub

unprotecting the sheets is via below code (not developed by me) and how do i run your code when i press alt+f8 cannot see any macro. sorry i am asking too much can i run filter only on the sheets which are tab colored "light blue" just to save some time? Const cStartFolder = "C:\Users\New folder" 'no slash at end Const cFileFilter = "*.xlsb" Const cPassword1 = "dummy" 'use empty quotes if blank Const cPassword2 = "astri" Const cPassword3 = "dfdfds" Const cPassword4 = "" Sub UnprotectAllWorksheets() Dim i As Long, j As Long, arr() As String, wkb As Workbook, wks As Worksheet ExtractFolder cStartFolder, arr() On Error Resume Next j = -1: j = UBound(arr) On Error GoTo 0 For i = 0 To j Set wkb = Workbooks.Open(arr(i), False) For Each wks In wkb.Worksheets On Error Resume Next wks.Unprotect cPassword1 wks.Unprotect cPassword2 On Error GoTo 0 Next wkb.Save wkb.Close Next End Sub Sub ExtractFolder(Folder As String, arr() As String) Dim i As Long, objFS As Object, objFolder As Object, obj As Object Set objFS = CreateObject("Scripting.FileSystemObject") Set objFolder = objFS.GetFolder(Folder) For Each obj In objFolder.SubFolders ExtractFolder obj.Path, arr() Next For Each obj In objFolder.Files If obj.Name Like cFileFilter Then On Error Resume Next i = 0: i = UBound(arr) + 1 On Error GoTo 0 ReDim Preserve arr(i) arr(i) = objFolder.Path & Application.PathSeparator & obj.Name End If Next End Sub message edited by oodai

AlwaysWillingToLearn December 1, 2015 at 08:01:42

Ok no worries i know how to unprotect sheets its was just that i didnt know your passwords. I will try to see what i can do, i may be away for a day or so

wow thank you so much.. for all your help...if you can make it work i will be really glad...two of my team members spend about 14 hours.. to do it manually so thought do something about it.. cannot thank you enough mate..thanks again

AlwaysWillingToLearn December 2, 2015 at 00:39:26

Have a play with this one, it seems to work for me now: 1) Unprotects sheets 2) filters the sheet 3) finds 'Invoice Created" 4) Created PDF from A1 to J and where 'Invoice Created' was found Please test and let me know what works and if something doesnt. in terms of tab colour, i am not sure if that can work but we can try, what you will need to do is tell me what the colour index is on the tab you are using, you can do this by running the following code Public Sub GetColour msgbox Sheets("SheetName").tab.colourindex End sub You will need to change the "SheetName" to the name of the blue sheet. Here is the rest of the code: Dim iExcel As Object Public Sub LoadFiles() ListFilesInFolder BrowseForFolder, True End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Const PW1 = "astri" Const PW2 = "dfdfds" Const PW3 = "" Const PW4 = "" Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Set iExcel = CreateObject("Excel.Application") Let iExcel.Visible = True iExcel.Workbooks.Open (FileItem.Path) Dim Sh As Worksheet Dim myRange As Range Dim ws As Worksheet Dim Strtry As String Dim Atok As Range Dim LR For Each Sh In iExcel.Worksheets On Error Resume Next Sh.Unprotect PW1 Sh.Unprotect PW2 Sh.Unprotect PW3 Sh.Unprotect PW4 Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) ' Auto Filter With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" End With ' Creates PDF LR = Sh.Range("I" & Rows.Count).End(xlUp).Row For i = 1 To LR If Sh.Cells(i, 9) = "Invoice Created" Then Sh.PageSetup.Orientation = xlLandscape Sh.Range("A1:J" & i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ "C:\" & Sh.Range("E3") & ".pdf", Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Exit For End If Next i Next Sh iExcel.DisplayAlerts = False iExcel.ActiveWorkbook.CheckCompatibility = False iExcel.ActiveWorkbook.Close iExcel.Quit iExcel.DisplayAlerts = True Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If 'Clean up Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing Set iExcel = Nothing End Sub message edited by AlwaysWillingToLearn

Thanks a lot mate!!! very silly question so if i have to run ti have copy pasted in VBE (Alt+f11) and clicked on run or is there any other way.

AlwaysWillingToLearn December 2, 2015 at 02:16:07

Hi, Yes, Open Excel, press ATL and F11, insert a module (right click in project export and select 'Inser > Module') and paste the code. To run the code, you can do two things 1) place the cursor over Public Sub LoadFiles Then Press F5 2) Go to 'Tools > Macros' double click on 'LoadFiles' Notes: Iv made a small change to the code in my previous post so please copy again, i changed 'Private sub LoadFiles' to 'Public Sub LoadFiles' Ensure you enter the reference to 'microsoft Scripting Runtime'

the macro is running for past two hours. is there a way that i can skip unprotect macro and run other macros? (below ones) 2) filters the sheet 3) finds 'Invoice Created" 4) Created PDF from A1 to J and where 'Invoice Created' Regards uday

AlwaysWillingToLearn December 2, 2015 at 04:58:41

If you dont want the macro to unprotect your worksheets then you can make the following change to the code Change sh.unprotect PW1 sh.unprotect PW2 sh.unprotect PW3 sh.unprotect PW4 to 'sh.unprotect PW1 'sh.unprotect PW2 'sh.unprotect PW3 'sh.unprotect PW4 This will comment out the unprotect code and will no longer attempt to unprotect any worksheets

ok thank you will try and message you again. thank you very much again.

AlwaysWillingToLearn December 2, 2015 at 05:50:56

You mentioned that the code was running for two hours, has it been opening the Excel files and creating the PDFs? or are you thinking that something is not working or just hanging? as i dont know your data set and layout of your workbooks i am unable to cater for instansces where the code could hang or crash. let us know how the code has been working thus far....

Sir one last question is there anyway that we can speed this up :) sorry if i am asking too much..

AlwaysWillingToLearn December 2, 2015 at 08:49:02

You need to answer my previous questions first so that i know where we stand with this code, there probably are ways to speed things up but you need to tell me what is working and what isnt. Thats way i can remove redundant code and optimise the new or existing code..... Does the code do what you intended it to do abait slowly?

the code is not working tried for at least 7-10 hours. shows it as calculation (25%,47% etc.) and the file gets closed. I have also commented out unprotect password code. is there a way that i can send you the sample files?

AlwaysWillingToLearn December 3, 2015 at 05:24:57

I will PM you my email address send me some of your templates and i will see what i can do.

sure thank you very much

AlwaysWillingToLearn December 7, 2015 at 07:01:29

Uday, Attached is working macro file to an email to you I have tested this on the 3 workbooks you sent me and it works perfectly. What i have done is 1) When each workbook is opened it will ONLY apply the macros on sheets that are NOT named "JJ", "SUMMARY" or "Rates". These sheets will be ignored as they are either empty or the layout is not consistant with the macro requested. There are two points which i dont understand and if you could let me know what you need i can perhaps update the code to accomodate your request 4-update a cell with previous month - unable to create macro as the cell is protected Which cell? And why can'y you update it, the password protection is removed so you should be able to? 6-combine pdfs based on file name - unable to create macro This can be achieve i just need to know what the file name will be and what other requirements you may have NOTES: You have requested that the pdf files are saved using cell E3 as the file name, however in the examples you sent me, E3 was empty therefore the PDF file was being overwritten in each itteration - Please make sure E3 has a unique value otherwise it will overwrite any existing PDF file with the same name!!!!! Here is the new code Dim iExcel As Object Public Sub LoadFiles() ListFilesInFolder BrowseForFolder, True End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Const PW1 = "astri" Const PW2 = "dfdfds" Const PW3 = "" Const PW4 = "" Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Set iExcel = CreateObject("Excel.Application") Let iExcel.Visible = True iExcel.DisplayAlerts = False iExcel.EnableEvents = False iExcel.AskToUpdateLinks = False iExcel.Workbooks.Open (FileItem.Path) Dim Sh As Worksheet Dim myRange As Range Dim ws As Worksheet Dim Strtry As String Dim Atok As Range Dim LR For Each Sh In iExcel.Worksheets On Error Resume Next If LCase(Sh.Name) <> LCase("JJ") And LCase(Sh.Name) <> LCase("SUMMARY") And LCase(Sh.Name) <> LCase("RATES") Then Sh.Select ' You dont need to select the sheet but for testing purposes it is useful, you can comment this out Sh.Unprotect PW1 Sh.Unprotect PW2 Sh.Unprotect PW3 Sh.Unprotect PW4 If Sh.AutoFilterMode Then ActiveSheet.ShowAllData DoEvents Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) myRange.Select With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" DoEvents End With ' Creates PDF LR = Sh.Range("I" & Rows.Count).End(xlUp).Row For i = 1 To LR If Sh.Cells(i, 9) = "INVOICE TOTAL" Then Sh.PageSetup.Orientation = xlLandscape Sh.Range("A1:J" & i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ "C:\" & Sh.Range("E3") & ".pdf", Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Exit For End If Next i End If Next Sh iExcel.DisplayAlerts = False iExcel.ActiveWorkbook.CheckCompatibility = False iExcel.ActiveWorkbook.Close ' iExcel.Quit iExcel.DisplayAlerts = True Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If 'Clean up Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing Set iExcel = Nothing End Sub message edited by AlwaysWillingToLearn

Thank you very much for the code I am testing with multiple files. Please give me a day . thanks a lot again

Hi Always willing the macro works really we i have tested in about 10 files. however, i few questions and help few of the files i will have bout 90 tabs and my excel as auto calculate option which is taking lot of time can i uncheck auto calculate and will it still be able to sub total for the filtered rows? once the macro is performed do i have close the sheet manually? as i have requested earlier can i merge my pdf files which has similar filename for example few of the file will have first 9 digits in common those have to be merged

AlwaysWillingToLearn December 9, 2015 at 01:38:15

✔ Best Answer

This seems to work a lot faster, what it does is turn off auto calculation, set the auto filter, then calculate, when i tested it before and after the code changes, the newer code seemed to go through the process a lot faster - please test I have also made changes that will close the workbook automatically once the process is complete. I am working on the pdf merging solution but right now dont have much time.... i will update when i have had a chance to work on it. Dim iExcel As Object Public Sub LoadFiles() ListFilesInFolder BrowseForFolder, True End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Const PW1 = "astri" Const PW2 = "dfdfds" Const PW3 = "" Const PW4 = "" Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Set iExcel = CreateObject("Excel.Application") Let iExcel.Visible = True iExcel.DisplayAlerts = False iExcel.EnableEvents = False iExcel.AskToUpdateLinks = False iExcel.Workbooks.Open (FileItem.Path) iExcel.Calculation = xlManual iExcel.CalculateBeforeSave = False Dim Sh As Worksheet Dim myRange As Range Dim ws As Worksheet Dim Strtry As String Dim Atok As Range Dim LR For Each Sh In iExcel.Worksheets On Error Resume Next If LCase(Sh.Name) <> LCase("JJ") And LCase(Sh.Name) <> LCase("SUMMARY") And LCase(Sh.Name) <> LCase("RATES") Then Sh.Select ' You dont need to select the sheet but for testing purposes it is useful, you can comment this out Sh.Unprotect PW1 Sh.Unprotect PW2 Sh.Unprotect PW3 Sh.Unprotect PW4 If Sh.AutoFilterMode Then ActiveSheet.ShowAllData DoEvents Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" DoEvents End With Sh.Calculate 'Creates PDF LR = Sh.Range("I" & Rows.Count).End(xlUp).Row For i = 1 To LR If Sh.Cells(i, 9) = "INVOICE TOTAL" Then Sh.PageSetup.Orientation = xlLandscape Sh.Range("A1:J" & i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ "C:\" & Sh.Range("E3").Value & ".pdf", Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Exit For End If Next i End If Next Sh iExcel.DisplayAlerts = False iExcel.ActiveWorkbook.CheckCompatibility = False iExcel.ActiveWorkbook.Close Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If iExcel.Application.Quit Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing Set iExcel = Nothing ThisWorkbook.Close False ThisWorkbook.Application.Quit End Sub

Hi Always willing, I can't thank you enough. I really appreciate the time and patience you have showed in building this solution. have a Great holiday. thank you again

AlwaysWillingToLearn December 9, 2015 at 07:04:06

Hi Uday, ok so i had some time to play with the merging of PDFs, this is not a very clean solution but it works and its pretty fast. I have not tested this extensively so you will need to test it. Note: The pdf files will no longer be saved to the 'C:\' drive, they will go to the same folder that you select when you start the code. What you need to do before this works is: 1) Add a reference to 'Acrobat' VBE > Tools > References - 'Acrobat' 2) Create a folder called 'Merged' where your excel files are stored - see note above. The code will create all your PDF files in this directory, then once all the excel files have been processed, it will load the names of all the pdfs it has created into sheet 1. It will then go through the list and look for the first 9 charectors of each file name, if they are the same it will merge them into one file. Please note not all the code is mine, i used code from http://www.vbaexpress.com/forum/sho... and modified it as needed Place in module 1 Dim iExcel As Object Public FilesPath As String Public Sub LoadFiles() ListFilesInFolder BrowseForFolder, False Call MergeAllPDFs ThisWorkbook.Close False Application.Quit End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Const PW1 = "astri" Const PW2 = "dfdfds" Const PW3 = "" Const PW4 = "" FilesPath = SourceFolderName If Right(FilesPath, 1) <> "\" Then FilesPath = FilesPath & "\" End If Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Set iExcel = CreateObject("Excel.Application") Let iExcel.Visible = True iExcel.DisplayAlerts = False iExcel.EnableEvents = False iExcel.AskToUpdateLinks = False iExcel.Workbooks.Open (FileItem.Path) iExcel.Calculation = xlManual iExcel.CalculateBeforeSave = False Dim Sh As Worksheet Dim myRange As Range Dim ws As Worksheet Dim Strtry As String Dim Atok As Range Dim LR For Each Sh In iExcel.Worksheets On Error Resume Next If LCase(Sh.Name) <> LCase("JJ") And LCase(Sh.Name) <> LCase("SUMMARY") And LCase(Sh.Name) <> LCase("RATES") Then Sh.Select ' You dont need to select the sheet but for testing purposes it is useful, you can comment this out Sh.Unprotect PW1 Sh.Unprotect PW2 Sh.Unprotect PW3 Sh.Unprotect PW4 If Sh.AutoFilterMode Then ActiveSheet.ShowAllData DoEvents Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" DoEvents End With Sh.Calculate 'Creates PDF LR = Sh.Range("I" & Rows.Count).End(xlUp).Row For i = 1 To LR If Sh.Cells(i, 9) = "INVOICE TOTAL" Then Sh.PageSetup.Orientation = xlLandscape Sh.Range("A1:J" & i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ FilesPath & Sh.Range("E3").Value & ".pdf", Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Exit For End If Next i End If Next Sh iExcel.DisplayAlerts = False iExcel.ActiveWorkbook.CheckCompatibility = False iExcel.ActiveWorkbook.Close Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If iExcel.Application.Quit Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing Set iExcel = Nothing ' ThisWorkbook.Close False ' ThisWorkbook.Application.Quit End Sub Place in module 2 Public efile As String Dim MyPath As String, MyFiles As String Dim a() As String, i As Long, f As String Public Sub MergeAllPDFs() MyPath = FilesPath Sheet1.Cells.Clear ' Populate the array a() by PDF file names If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" ReDim a(1 To 2 ^ 14) f = Dir(MyPath & "*.pdf") While Len(f) LastRow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row i = i + 1 a(i) = f Dim Dotpos Dotpos = InStr(1, f, ".", vbTextCompare) If Dotpos > 0 Then Dotpos = Dotpos - 1 End If If Sheet1.Range("A1") = Empty Then Sheet1.Range("A1") = Mid(f, 1, Dotpos) Else Sheet1.Range("A" & LastRow + 1) = Mid(f, 1, Dotpos) End If f = Dir() Wend test End Sub Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf") ' ZVI:2013-08-27 <a href="http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X" target="_blank" rel="nofollow">http://www.vbaexpress.com/forum/sho...</a> ' 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 & "\Merged\" & DestFile) Then ' MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled" End If End If exit_: ' 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 test() Dim Bcell As Range Dim x, y, StartVal Dim b As String Set uRange = Range("A1") Set lRange = Range("A" & Rows.Count).End(xlUp) StartVal = 1 i = 1 b = Empty For Each Bcell In Range(uRange, lRange) x = Left(Bcell.Value, 9) y = Left(Bcell.Offset(1, 0).Value, 9) If x <> y Then For Each cell In Range("A" & StartVal & ":" & "A" & Bcell.Row) b = b & cell.Value & ".pdf" & "," Next cell efile = Range("A" & StartVal) & "-merged" & ".pdf" Call MergePDFs(MyPath, b, efile) b = Empty StartVal = Bcell.Row + 1 End If Next Bcell End Sub

Thank you Thank you Thank you so much my friend. This is great. works amazing. You are a genius.

Hi Always willing, sorry to come back. for some reason after the macro is run the files are not getting closed what do i need to change this to close automatically

AlwaysWillingToLearn December 18, 2015 at 03:32:16

Hi Oodai which files are not being closed the excel? Im on christmas holidays now so wont be able to look at it until the new year

No problem Have a good Christmas and New year in advance mate. the excel files where we apply filters (Sub LoadFiles macro) and create pdfs. Not very urgent. Enjoy your holidays.

Hi AlwaysWillingToLearn, Wish you happy New Year. The code provided works brilliant except on three issues 1. excel file will not close automatically 2. excel file which are big in size more than 10 mb (owing to too many tabs >50 tabs) take hours 3pdf merge not happening creates a files as merged but cannot see pages. Please help if you have time. Thanks in advance!!!

AlwaysWillingToLearn January 8, 2016 at 03:49:30

oodai, Happy new year. 1) replace the old 'LoadFile' sub with the following - this will address the closing issue Public Sub LoadFiles() ListFilesInFolder BrowseForFolder, False Call MergeAllPDFs ThisWorkbook.Application.DisplayAlerts = False ThisWorkbook.Application.Quit End Sub 2) there is not much i can do about the time it takes to process the larger workbooks, if there are 50 plus worksheets then that is what it is unfortunately 3) You previously mentioned that the first 9 charectors of the pdf files will be the same, this is what i use to merge the related pdfs so for example in one particular workbook across all the sheets i would expect range E3 to be something like AAAAAAAAAMonday AAAAAAAAATuesday AAAAAAAAAWednesday BBBBBBBBBThursday BBBBBBBBBFriday BBBBBBBBBSaturday When the merging process begins it will check the first 9 charectors of each file and use them to group and merge the pages so in this example all pages from file begining with 'AAAAAAAAA' will be merged together and all files begining with 'BBBBBBBBB' will be merged together. Please check your file names in E3 to ensure they are consistant. Here is the code please ensure you add references to - Acrobat - Microsoft scripting runtime Module 1 Dim iExcel As Object Public FilesPath As String Public Sub LoadFiles() ListFilesInFolder BrowseForFolder, False Call MergeAllPDFs ThisWorkbook.Application.DisplayAlerts = False ThisWorkbook.Application.Quit End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean) Const PW1 = "astri" Const PW2 = "dfdfds" Const PW3 = "" Const PW4 = "" FilesPath = SourceFolderName If Right(FilesPath, 1) <> "\" Then FilesPath = FilesPath & "\" End If Dim FSO As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder Dim FileItem As Scripting.file Dim r As Long Set FSO = New Scripting.FileSystemObject Set SourceFolder = FSO.GetFolder(SourceFolderName) For Each FileItem In SourceFolder.Files Set iExcel = CreateObject("Excel.Application") Let iExcel.Visible = True iExcel.DisplayAlerts = False iExcel.EnableEvents = False iExcel.AskToUpdateLinks = False iExcel.Workbooks.Open (FileItem.Path) iExcel.Calculation = xlManual iExcel.CalculateBeforeSave = False Dim Sh As Worksheet Dim myRange As Range Dim ws As Worksheet Dim Strtry As String Dim Atok As Range Dim LR For Each Sh In iExcel.Worksheets On Error Resume Next If LCase(Sh.Name) <> LCase("JJ") And LCase(Sh.Name) <> LCase("SUMMARY") And LCase(Sh.Name) <> LCase("RATES") Then Sh.Select ' You dont need to select the sheet but for testing purposes it is useful, you can comment this out Sh.Unprotect PW1 Sh.Unprotect PW2 Sh.Unprotect PW3 Sh.Unprotect PW4 If Sh.AutoFilterMode Then ActiveSheet.ShowAllData DoEvents Set myRange = Sh.Range("A9", Sh.Range("J9").End(xlDown)) With myRange .AutoFilter Field:=1, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic .AutoFilter Field:=10, Criteria1:="<>0" DoEvents End With Sh.Calculate 'Creates PDF LR = Sh.Range("I" & Rows.Count).End(xlUp).Row For i = 1 To LR If Sh.Cells(i, 9) = "INVOICE TOTAL" Then Sh.PageSetup.Orientation = xlLandscape Sh.Range("A1:J" & i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ FilesPath & Sh.Range("E3").Value & ".pdf", Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Exit For End If Next i End If Next Sh iExcel.DisplayAlerts = False iExcel.ActiveWorkbook.CheckCompatibility = False iExcel.ActiveWorkbook.Close False Next FileItem If IncludeSubfolders Then For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, True Next SubFolder End If iExcel.Application.Quit Set FileItem = Nothing Set SourceFolder = Nothing Set FSO = Nothing Set iExcel = Nothing ' ThisWorkbook.Close False ' ThisWorkbook.Application.Quit End Sub Module 2 Public efile As String Dim MyPath As String, MyFiles As String Dim a() As String, i As Long, f As String Public Sub MergeAllPDFs() MyPath = FilesPath Sheet1.Cells.Clear ' Populate the array a() by PDF file names If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" ReDim a(1 To 2 ^ 14) f = Dir(MyPath & "*.pdf") While Len(f) LastRow = Sheet1.Range("A" & Rows.Count).End(xlUp).Row i = i + 1 a(i) = f Dim Dotpos Dotpos = InStr(1, f, ".", vbTextCompare) If Dotpos > 0 Then Dotpos = Dotpos - 1 End If If Sheet1.Range("A1") = Empty Then Sheet1.Range("A1") = Mid(f, 1, Dotpos) Else Sheet1.Range("A" & LastRow + 1) = Mid(f, 1, Dotpos) End If f = Dir() Wend test End Sub Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf") ' ZVI:2013-08-27 <a href="http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X" target="_blank" rel="nofollow">http://www.vbaexpress.com/forum/sho...</a> ' 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 & "\Merged\" & DestFile) Then ' MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled" End If End If exit_: ' 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 test() Dim Bcell As Range Dim x, y, StartVal Dim b As String Set uRange = Range("A1") Set lRange = Range("A" & Rows.Count).End(xlUp) StartVal = 1 i = 1 b = Empty For Each Bcell In Range(uRange, lRange) x = Left(Bcell.Value, 9) y = Left(Bcell.Offset(1, 0).Value, 9) If x <> y Then For Each cell In Range("A" & StartVal & ":" & "A" & Bcell.Row) b = b & cell.Value & ".pdf" & "," Next cell efile = Range("A" & StartVal) & "-merged" & ".pdf" Call MergePDFs(MyPath, b, efile) b = Empty StartVal = Bcell.Row + 1 End If Next Bcell End Sub i will email you the workbook also.

Thanks a lot Always willing. I cannot ask you for more but only one point. in the merge pdf yes you are right it created based on the first nine character but firtst nine to be in the file name. example i get a pdf file for which i will have the same file name as i have in the cell e3 of current file. anyway you already helped me a lot. will not mind even if you leave the solution as it is now.. thanks again. glad to know such a wonderful person