Run excel macro code recursively on all files insi

Question

I have a folder where I have many sub-folders and inside of them more than 1000 Excel files.

I want to run a specific macro (that changes a workbook) on all these files.

Already saw the following answer.

Sub ProcessFiles()
    Dim Filename, Pathname As String
    Dim wb As Workbook

    Pathname = ActiveWorkbook.Path & "\C:\...\EXCL\"
    Filename = Dir(Pathname & "*.xlsx")
    Do While Filename <> ""
        Set wb = Workbooks.Open(Pathname & Filename)
        DoWork wb
        wb.Close SaveChanges:=True
        Filename = Dir()
    Loop
End Sub

Sub DoWork(wb As Workbook)
    With wb
        'Do your work here
        ......
    End With
End Sub

There are two problems:
1. this will be extremely slow. Is there a faster way?
2. this will only run on the files in the matching folder and not the files in all sub-folders. Is there way to do that for files in sub-folders as well?

Answer 1

If I get this right you need a function which collects all xl files in a directory and subdirs. This function will do that:

Public Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function


Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

And this shows how to use it

Sub TesterFiles()

Dim colFiles As New Collection

    RecursiveDir colFiles, "Your Dir goes here...", "*.XLS*", True

    Dim vFile As Variant
    For Each vFile In colFiles
        ' Do sth with the file
        Debug.Print vFile
    Next vFile

End Sub

Answer 2

Nice one Storax! I would use the script that Storax posted, and modify it just a tad.

i = 1
Dim vFile As Variant
For Each vFile In colFiles
    ' Do sth with the file
    Range("A" & i).Value = vFile
    i = i + 1
Next vFile

I think it's just easier to work with a list. Anyway, once you have the file structure, you can run through those elements in the array you just created. Use the script below to do that.

Sub LoopThroughRange()

Dim rng As Range, cell As Range
Set rng = Range("A1:A13")

For Each cell In rng

        'For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(cell)
            On Error GoTo 0

            If Not mybook Is Nothing Then


                'Change cell value(s) in one worksheet in mybook
                On Error Resume Next
                With mybook.Worksheets(1)
                    If .ProtectContents = False Then
                        .Range("A1").Value = "My New Header"
                    Else
                        ErrorYes = True
                    End If
                End With


                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    'Close mybook without saving
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook
                ErrorYes = True
            End If

        'Next Fnum

Next cell

End Sub

The idea comes straight from here.

http://www.rondebruin.nl/win/s3/win010.htm

Pay attention to this part: 'Change cell value(s) in one worksheet in mybook That's where you want to put specific your code to do exactly what you want to do.

I just modified my OP. It's a lot easier, and a little different, than I initially made it out to be. I've adjusted the script accordingly.

Answer 3

As far as I know, VBA can't edit closet workbook. If you want to do work for every workbook in every subfolder, subfolder of subfolder etc. you can use the following code. I added condition, that it have to be .xlsx file, you can change it on .xls, .xlsb or whatever you want.

Sub ProcessFiles()
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Dim MyPath As String
Dim myExtension As String
Dim FldrPicker As FileDialog

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo EmptyEnd
        MyPath = .SelectedItems(1)
    End With

    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Call GetAllFiles(MyPath, objFSO)
    Call GetAllFolders(MyPath, objFSO)
    Application.ScreenUpdating = True

    MsgBox "Complete."

EmptyEnd:
End Sub

Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objFile As Object

    Set objFolder = objFSO.GetFolder(strPath)
    For Each objFile In objFolder.Files
            DoWork objFile.Path
    Next objFile
End Sub

Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objSubFolder As Object

    Set objFolder = objFSO.GetFolder(strFolder)
    For Each objSubFolder In objFolder.subfolders
        Call GetAllFiles(objSubFolder.Path, objFSO)
        Call GetAllFolders(objSubFolder.Path, objFSO)
    Next objSubFolder
End Sub

Sub DoWork(strFile As String)
Dim wb As Workbook
    If Right(strFile, 4) = "xlsx" Then
        Set wb = Workbooks.Open(Filename:=strFile)
        With wb
            'Do your work here
            ......
            .Close True
        End With
    End If
End Sub