Perform an action in each sub-folder independently

sans,

For something like this where you need to make changes at the level of each subfolder instead of at the level of each file, the GetAllFiles sub needed some modification.

Adjusted tgr code:

Sub tgr()
    
    Dim ws As Worksheet
    Dim lSec As MsoAutomationSecurity
    Dim arrFiles As Variant
    Dim varFilePath As Variant
    
    With Application
        lSec = .AutomationSecurity
        .AutomationSecurity = msoAutomationSecurityForceDisable
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    GetAllFiles "C:\Test2", "xls*", True
    
    With Application
        .AutomationSecurity = lSec
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
End Sub

Adjusted GetAllFiles code:

Public Sub GetAllFiles(ByVal strFolderPath As String, Optional ByVal strExt As String = "*", Optional ByVal bCheckSubfolders As Boolean = False)
    
    Dim wbDest As Workbook
    Dim FSO As Object
    Dim oFile As Object
    Dim oFolder As Object
    Dim strName As String
    Dim sSep As String
    Dim strNewFilePath As String
    Dim i As Long
    Dim bNoData As Boolean
    
    sSep = Application.PathSeparator
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set wbDest = Workbooks.Add
    strNewFilePath = strFolderPath
    Select Case (Right(strNewFilePath, Len(sSep)) = sSep)
        Case True:  strName = Mid(strFolderPath, InStrRev(Left(strFolderPath, Len(strFolderPath) - Len(sSep)), sSep) + Len(sSep))
                    strNewFilePath = strFolderPath & strName & ".xlsm"
        Case Else:  strName = Mid(strFolderPath, InStrRev(strFolderPath, sSep) + Len(sSep))
                    strNewFilePath = strNewFilePath & sSep & strName & ".xlsm"
    End Select
    
    For Each oFile In FSO.GetFolder(strFolderPath).Files
        If LCase(FSO.GetExtensionName(oFile.Path)) Like LCase(strExt) Then
            With Workbooks.Open(oFile.Path)
                .Sheets(1).Copy After:=wbDest.Sheets(wbDest.Sheets.Count)
                .Close False
            End With
            Kill oFile.Path
        End If
    Next oFile
    
    bNoData = False
    For i = wbDest.Sheets.Count To 1 Step -1
        If wbDest.Sheets(i).UsedRange.Address = "$A$1" And Len(wbDest.Sheets(i).Range("A1").Value) = 0 Then
            Select Case (wbDest.Sheets.Count > 1)
                Case True:  wbDest.Sheets(i).Delete
                Case Else:  bNoData = True
            End Select
        End If
    Next i
    wbDest.SaveAs strNewFilePath, xlOpenXMLWorkbookMacroEnabled
    wbDest.Close False
    If bNoData = True Then Kill strNewFilePath
    
    If bCheckSubfolders = True Then
        For Each oFolder In FSO.GetFolder(strFolderPath).SubFolders
            GetAllFiles oFolder.Path, strExt, True
        Next oFolder
    End If
    
    Set wbDest = Nothing
    Set FSO = Nothing
    
End Sub

You're very welcome

sans,

I would recommend exporting the desired modules to a folder that they will be imported from for each workbook. Exported modules have a .bas file extension.

Because this is happening for every file found in each subfolder (so it is happening at the file level and not the folder level like earlier), use the standard GetAllFiles sub provided in your other thread:
http://www.excelforum.com/excel-prog...book-name.html


Then Sub tgr would looke like this:

Sub tgr()
    
    'Change this to the correct folder path that contains the .bas files
    'Be sure to include the ending \
    Const strModuleFolderPath As String = "C:\Modules to Import\"
    
    Dim ws As Worksheet
    Dim arrFiles As Variant
    Dim varFilePath As Variant
    Dim strModuleName As String
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set ws = Sheets.Add
    GetAllFiles ws.Range("A1"), "C:\Test", "xls*", True
    
    arrFiles = Application.Transpose(ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)).Value)
    ws.Delete
    
    For Each varFilePath In arrFiles
        With Workbooks.Open(varFilePath)
            strModuleName = Dir(strModuleFolderPath & "*.bas")
            If Len(strModuleName) > 0 Then
                Do
                    .VBProject.VBComponents.Import strModuleFolderPath & strModuleName
                Loop While Len(strModuleName) > 0
            End If
            .Close True
        End With
    Next varFilePath
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Set ws = Nothing
    Erase arrFiles
    
End Sub

oh, lol, I forgot to add the advance loop line, so it was repeating an infinite loop until it couldn't handle it anymore. That's what I get for posting untested code, haha. Line in red has been added:

Sub tgr()
    
    'Change this to the correct folder path that contains the .bas files
    'Be sure to include the ending \
    Const strModuleFolderPath As String = "C:\Modules to Import\"
    
    Dim ws As Worksheet
    Dim arrFiles As Variant
    Dim varFilePath As Variant
    Dim strModuleName As String
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set ws = Sheets.Add
    GetAllFiles ws.Range("A1"), "C:\Test", "xls*", True
    
    arrFiles = Application.Transpose(ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)).Value)
    ws.Delete
    
    For Each varFilePath In arrFiles
        With Workbooks.Open(varFilePath)
            strModuleName = Dir(strModuleFolderPath & "*.bas")
            If Len(strModuleName) > 0 Then
                Do
                    .VBProject.VBComponents.Import strModuleFolderPath & strModuleName
                    strModuleName = Dir
                Loop While Len(strModuleName) > 0
            End If
            .Close True
        End With
    Next varFilePath
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Set ws = Nothing
    Erase arrFiles
    
End Sub