Execute macro on multiple excel files after after selecting folder from multiple levels

[VAPALIPOT]

I have research this question and found some VBA code that works if one folder is selected that has the excel files contained in it. If I try to drill down through multiple folders and subfolders, the code quits and indicates through the message box that it has finished when it really hasn't. Here is the code that I copied from another source that processes the excel files in one folder, but doesn't allow me to drill down through multiple subfolders to get to it.

Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

            Application.ScreenUpdating = False
            Application.EnableEvents = False 
            Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
            Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

                        With FldrPicker
                        .Title = "Select A Target Folder"
                        .AllowMultiSelect = False
                        If .Show <> -1 Then GoTo NextCode
                        myPath = .SelectedItems(1) & "\"
            End With
NextCode:
            myPath = myPath
            If myPath = "" Then GoTo ResetSettings
  myExtension = "*.xls*"
  myFile = Dir(myPath & myExtension)
  Do While myFile <> ""
    
            Set wb = Workbooks.Open(Filename:=myPath & myFile)
    
            DoEvents
    'Sample execution code [Change First Worksheet's Background Fill Blue]
            ‘wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
            wb.Close SaveChanges:=True
            DoEvents
            myFile = Dir
  Loop

            MsgBox "Task Complete!"
ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

I thought that the Application.GetOpenFolderName would work instead of FolderDialogPicker, but it doesn't seem to allow the selection.
Any assistance would be appreciated.
Thanks

 

[ParamRay]

Can loop through folders and subfolders using the Microsoft Scripting Runtime object model and a recursive procedure:

Public Sub SetBackgroundColor()
' ===================
' || RUN THIS PROC ||
' ===================

  Const strPROC_NAME = "Set Background Color"
  Dim strFolderPath As String
  On Error GoTo ErrHandler
  
  With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
  End With
  
  strFolderPath = PickFolder()
  If strFolderPath = "" Then GoTo ExitProc
  Call ProcessExcelFiles(strFolderPath)
  MsgBox "Processing completed.", vbInformation, strPROC_NAME
  
ExitProc:
  On Error Resume Next
  With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .StatusBar = False
    .Calculation = xlCalculationAutomatic
  End With
  Exit Sub
  
ErrHandler:
  MsgBox "Error " & Err.Number & ":" & vbCrLf & Err.Description, vbCritical, strPROC_NAME
  Resume ExitProc
End Sub

Private Sub ProcessExcelFiles(ByVal strFolderPath As String)
  Static intFileCount As Integer
  Dim objFileSys As Object
  Dim objFolder As Object
  Dim objFile As Object
  
  Set objFileSys = CreateObject("Scripting.FileSystemObject")
  For Each objFile In objFileSys.GetFolder(strFolderPath).Files
    If objFileSys.GetExtensionName(objFile.Path) Like "*xl*" Then
      Call ProcessExcelFile(objFile.Path)
      intFileCount = intFileCount + 1
      Application.StatusBar = "Processing file #" & intFileCount & "..."
      DoEvents
    End If
  Next objFile
  
  For Each objFolder In objFileSys.GetFolder(strFolderPath).SubFolders
    Call ProcessExcelFiles(objFolder.Path)
  Next objFolder
  
  Set objFileSys = Nothing
  Set objFolder = Nothing
  Set objFile = Nothing
End Sub

Private Sub ProcessExcelFile(ByVal strFilePath As String)
  With Workbooks.Open(strFilePath, False)
    .Worksheets(1).Range("A1:Z1").Interior.Color = &HAE6233
    .Close SaveChanges:=True
  End With
End Sub

Private Function PickFolder() As String
  With Application.FileDialog(4)
    .ButtonName = "Select Folder"
    If .Show Then PickFolder = .SelectedItems(1)
  End With
End Function

 

[VAPALIPOT]

Thanks for your reply. I'll give a try now.

 

[VAPALIPOT]

Thank you for providing this MACRO. It works with excellent speed! However, it applies the changes to ALL of the files in every subfolder that is present in the Selected Folder. In my situation, I have files that have to be processed in only one subfolder. Other files present in either higher or lower order subfolders I would like to remain untouched. So the first Private Subroutine looks like the location where a specific subfolder would need to be identified? This is the place in the program where I have struggled to write the correct code, so I am interested in seeing how it is done.
How is the code written to allow the selection of just one subfolder from all of the others present in the main folder?
I appreciate your help getting this macro developed.

 

[ParamRay]

Confused. Why not just use your original code and select the subfolder instead of the parent folder?