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

November 28, 2015 at 12:29:47
Specs: Windows 7
I have about six visual basic (vba) macros how can i run all those for all the excel (xlsm,xlsx,xlsb) files in a directory

See More: Run 6 VBA macros at once for all excel files in a directory

Report •


✔ Best Answer
December 9, 2015 at 01:38:15
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



#1
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


Report •

#2
November 30, 2015 at 01:28:32
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


Report •

#3
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


Report •

Related Solutions

#4
November 30, 2015 at 23:49:46
it is giving me an error "Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)" at this line. i have also enabled scripting runtime

Report •

#5
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.


Report •

#6
December 1, 2015 at 01:21:35
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


Report •

#7
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.


Report •

#8
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


Report •

#9
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




Report •

#10
December 1, 2015 at 03:40:32
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


Report •

#11
December 1, 2015 at 04:31:18
It looks like i will need to rewrite some of your code, let me work on it.

Report •

#12
December 1, 2015 at 05:02:00
Thanks a lot. not sure if i can ask this. is there a way i can contact you over the phone?

Report •

#13
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....


Report •

#14
December 1, 2015 at 06:12:57
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.


Report •

#15
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



Report •

#16
December 1, 2015 at 07:41:40
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


Report •

#17
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

Report •

#18
December 1, 2015 at 08:08:01
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


Report •

#19
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


Report •

#20
December 2, 2015 at 02:05:19
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.

Report •

#21
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'


Report •

#22
December 2, 2015 at 04:52:18
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


Report •

#23
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


Report •

#24
December 2, 2015 at 05:45:15
ok thank you will try and message you again. thank you very much again.

Report •

#25
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....


Report •

#26
December 2, 2015 at 08:37:32
Sir one last question is there anyway that we can speed this up :) sorry if i am asking too much..

Report •

#27
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?


Report •

#28
December 3, 2015 at 03:22:04
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?


Report •

#29
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.

Report •

#30
December 3, 2015 at 07:02:28
sure thank you very much

Report •

#31
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


Report •

#32
December 7, 2015 at 19:15:44
Thank you very much for the code I am testing with multiple files. Please give me a day . thanks a lot again

Report •

#33
December 8, 2015 at 08:20:11
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


Report •

#34
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


Report •

#35
December 9, 2015 at 02:21:38
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

Report •

#36
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



Report •

#37
December 10, 2015 at 01:08:46
Thank you Thank you Thank you so much my friend. This is great. works amazing. You are a genius.

Report •

#38
December 18, 2015 at 01:25:32
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

Report •

#39
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


Report •

#40
December 18, 2015 at 08:14:01
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.

Report •

#41
January 6, 2016 at 04:40:51
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!!!


Report •

#42
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.


Report •

#43
January 10, 2016 at 23:56:33
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


Report •


Ask Question