Loop through all sub-folders of a main folder and rename sheet same as workbook name

[sans]

Hi to everyone,

I have been looking for a solution for the above problem for the past few days but haven't found a solution so I am turning for help. I have found some relevant macros but haven't been able to modify them successfully.

I am looking for a macro that loops through all sub-folders of a main folder, the levels of sub-folders can be anything from 1 level to sometimes more than 5 levels, and perform an action. In this case I would like to rename the first sheet of each workbook the same as the workbook name.

Any help is greatly appreciated, many thanks!

[tigeravatar]

sans,

The following macro calls a custom subroutine I created awhile ago which is used to loop through all subfolders in a main folder and get all of the full file paths and names that meet a file extension criteria. In this case, I set the file extension criteria to be "xls*" to that it will pick up only Excel files (xls, xlsx, and xlsm). Then it uses that file's workbook name to rename the first sheet to be the same name as the workbook. In some cases, this may not be strictly possible due to sheet name character limit and illegal characters in the sheet name, but the macro will get it as close as possible (and in the majority of cases it should be an exact match). Just change the "C:\Test" (in red in the code) to the correct folder path of the main folder.

Sub tgr()
    
    Dim ws As Worksheet
    Dim arrFiles As Variant
    Dim varFilePath As Variant
    Dim strNameWS 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
        strNameWS = Replace(Mid(varFilePath, InStrRev(varFilePath, "\") + 1), Mid(varFilePath, InStrRev(varFilePath, ".")), vbNullString)
        For i = 1 To 7
            strNameWS = Replace(strNameWS, Mid(":\/?*[]", i, 1), " ")
        Next i
        strNameWS = Trim(Left(WorksheetFunction.Trim(strNameWS), 31))
        With Workbooks.Open(varFilePath)
            .Sheets(1).Name = strNameWS
            .Close True
        End With
    Next varFilePath
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Set ws = Nothing
    Erase arrFiles
    
End Sub

Here is the subroutine I created that is called in the above macro. It is a recursive subroutine (it calls itself) so it doesn't matter how many subfolders there are, nor how many subfolders each subfolder has, and so on:

Public Sub GetAllFiles(ByRef rngDest As Range, ByVal strFolderPath As String, Optional ByVal strExt As String = "*", Optional ByVal bCheckSubfolders As Boolean = False)
    
    Dim FSO As Object
    Dim oFile As Object
    Dim oFolder As Object
    Dim strFiles(1 To 65000) As String
    Dim FileIndex As Long
    
    FileIndex = 0
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    For Each oFile In FSO.GetFolder(strFolderPath).Files
        If LCase(FSO.GetExtensionName(oFile.Path)) Like LCase(strExt) Then
            FileIndex = FileIndex + 1
            strFiles(FileIndex) = oFile.Path
        End If
    Next oFile
    If FileIndex > 0 Then rngDest.Resize(FileIndex).Value = Application.Transpose(strFiles)
    
    If bCheckSubfolders = True Then
        Set rngDest = rngDest.Offset(FileIndex)
        For Each oFolder In FSO.GetFolder(strFolderPath).SubFolders
            GetAllFiles rngDest, oFolder.Path, strExt, True
        Next oFolder
    End If
    
    Set FSO = Nothing
    Erase strFiles
    
End Sub

[sans]

Hi tigeravatar,

The macro works absolutely fantastic. Thank you very much! I tested it with a few different folders structures with various levels of subfolders and I haven't encountered any errors. With the last attempt though, it simply stopped calculating without giving any errors or any window popping up, it just stopped calculating. Is there a limit on how many files it can process at any one time?


Can the above macro that calls all sub-folders be modified and to be used to carry out any other simple functions, i.e. open files in all sub-folders and perform another action in each file?

Many thanks for your help!

[tigeravatar]

The GetAllFiles subroutine can return a maximum of 65,000 files. If you have more than that, it will probably stall out, though I would expect an "Out of Memory" or "Subscript out of range" error. Also, the more files it proccesses, the longer it will take. So if it is processing 10,000 files, it may look like it has stalled, when its actually just taking awhile to complete.

As for changing the tgr macro, yes that can be changed to do whatever you need for each file found.

[sans]

Hi tigeravatar,

No problem, thank you for the additional details.

The macro was fast as I could see it working in the background in the vb editor window running through all the workbooks. Very fast actually. It works absolutely great.

About changing the macro to perform other actions, as I understand I should leave the Public Sub GetAllFiles as it is and simply alter the tgr.

For example, if I have separate workbook named "Data Workbook" and would like to copy a range from this workbook and paste it in all the sheets of the workbooks in the folders/sub-folders, would this be achievable by simply changing the tgr macro? Can the tgr be changed to a kind of "template" where I can use it to insert other macros to perform different functions?

Thank you for all the help.

[tigeravatar]

Here is the generic code for tgr - note that you can name it to whatever you want by changing the "tgr" in the very first line: Sub tgr()
As for what the code will be, that depends on the specific task you have in mind.
Some tasks will require new variables, like the renaming worksheet originally shown. Your request to use a workbook named "data workbook" to copy a range from there and paste it in all sheets of all workbooks returned with GetAllFiles will take a few new variables. I can provide that code if you'd like, or you can try to work it out from here.

Sub tgr()
    
    'Declare variables
    Dim ws As Worksheet
    Dim arrFiles As Variant
    Dim varFilePath As Variant
    
    'Turn off ScreenUpdating
    'This prevents "screen flickering" and allows the code to run faster
    Application.ScreenUpdating = False
    
    'Turn off DisplayAlerts
    'This prevents the warning message when the temporary worksheet used by GetAllFiles is deleted
    Application.DisplayAlerts = False
    
    'Prepare the temp worksheet that will be used by GetAllFiles
    Set ws = Sheets.Add
    
    'Run the GetAllFiles subroutine to go through all subfolders within a main folder
    'Change the "C:\Test" to be the correct main folder path
    GetAllFiles ws.Range("A1"), "C:\Test", "xls*", True
    
    'Load all files found from GetAllFiles into an array named arrFiles
    arrFiles = Application.Transpose(ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)).Value)
    
    'The temporary worksheet is no longer needed, delete it
    ws.Delete
    
    'Loop through each file in the array arrFiles
    For Each varFilePath In arrFiles
        
        'Open the workbook
        With Workbooks.Open(varFilePath)
            
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            '                                                                '
            '   This is where code goes that will affect each workbok        '
            '   Perform whatever function you need on each workbook          '
            '   This will be repeated for each workbook listed in arrFiles   '
            '                                                                '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            
            'Close the workbook and save the changes
            'The True can be set to False in order to close without saving
            .Close True
        End With
        
    Next varFilePath    'Advance to the next file
    
    'Re-enable ScreenUpdating and DisplayAlerts
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    'Object and Array variable cleanup
    Set ws = Nothing
    Erase arrFiles
    
End Sub

[sans]

That is amazing, thank you very much!!!
If you could help me with the second function as well it would be simply great as I simply have no idea how to achieve this - or the rest of the functions I would like to perform I will need to find some other macros and try to edit them to the best of my understanding.
Thank you very much for all your help!

[tigeravatar]

sans,

It would look something like this:

Sub tgr()
    
    Dim ws As Worksheet
    Dim arrFiles As Variant
    Dim varFilePath As Variant
    
    'Extra variables for specific task
    Dim wbData As Workbook
    Dim rngCopy As Range
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'Assign extra variables
    'Be sure to change the Data Workbook filepath to be correct
    'Be sure to change the sheet name from Sheet1 to the correct sheet name within wbData
    'Be sure to change the range A1:A10 to the correct range of cells that will be copied
    Set wbData = Workbooks.Open("C:\Test\Data Workbook.xls")
    Set rngCopy = wbData.Sheets("Sheet1").Range("A1:A10")
    
    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)
            'Loop through each worksheet in the opened workbook
            For Each ws In .Sheets
                'Copy rngCopy and paste it to the target cell in the worksheet
                rngCopy.Copy Destination:=ws.Range("A1")
            Next ws
            .Close True
        End With
        
    Next varFilePath
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    Set ws = Nothing
    Set wbData = Nothing
    Set rngCopy = Nothing
    Erase arrFiles
    
End Sub

[sans]

Yep, my bad. There was something pasted wrong in the file path, (I think an additional space), after I recopied it everything works absolutely amazing! Thank you very much for your help!!! I can now compare the template in post #6 and the latest macro and try and edit it for all the few other functions I have in mind. Again, a millions thanks for all your help!!!

[sans]

Hi tigeravatar,
Thank you so very much for your reply! When I hit alt+F8 and point to the macro to run it, the Run button is greyed out. I changed the path,file extension and source path. I am sure I am doing something wrong, is there anything else should be aware of?
A million thanks for the help.

[tigeravatar]

You're very welcome

[sans]

The above macro copies a range from a specified sheet in workbook and pastes it in all the workbooks in all the subfolders.

I am trying to edit the above macro to copy a Sheet named "Summary" in all the workbooks in the subfolders. This is what I came up with:

Sub tgr_Copy_Sheet_to_Wbs_in_Subfolders()
    
    Dim ws As Worksheet
    Dim arrFiles As Variant
    Dim varFilePath As Variant
    
    'Extra variables for specific task
    Dim wbData As Workbook
    Dim sheetoCopy As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    
    Set wbData = Workbooks.Open("F:\Folder\Updates\Updates Sheet.xlsm")
    Set sheetoCopy = wbData.Sheets("Summary")
    
    Set ws = Sheets.Add
    GetAllFiles ws.Range("A1"), "C:\Users\nast\Desktop\Main", "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)
                
                wbData.Sheets("Summary").Copy
          
            .Close True
        End With
        
    Next varFilePath
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    Set ws = Nothing
    Set wbData = Nothing
    Set sheetoCopy = Nothing
    Erase arrFiles
    
End Sub

For some reason, when running the code, it copies the sheet named summary from the Updates folder, but instead of copying the sheet in each of the workbooks in the subfolders, it creates extra workbooks and copies the worksheet summary there. After 2 days, I can't figure out where I am going wrong

[tigeravatar]

When you do a Sheets.Copy method, you have to specify where you want the copied sheet to be placed, otherwise a new workbook gets created with the copied sheet. So basically:

If you want the Summary sheet to be at the beginning of the workbook:

wbData.Sheets("Summary").Copy Before:=.Sheets(1)

If you want the Summary sheet to be at the end of the workbook:

wbData.Sheets("Summary").Copy After:=.Sheets(.Sheets.Count)

[sans]

Hi ta,

Absolutely great, worked like a charm! Thank you very very much for the help once again!

As a side note, I have learned a lot from studying the help you have been providing here on the forum!

Thank you!

[tigeravatar]

Glad to hear it! If you look at some of my earliest posts, you can see just how much of a noob I was back then, lol

[sans]

ta, should I assume that all of your vba skills are self taught?! Your "style" of coding has a simplicity to it which makes it in a way very understandable (to newcomers in vba)!

[tigeravatar]

Yea, I am entirely self-taught. Lots of practice and google, hehe. I appreciate your compliment regarding my style of coding. I generally try to make it as readable as possible so I don't have to comment everything