Copy worksheet from workbook in multiple sub-folders

[WWII_Buff]

Hey guys! I found this vba code posted by Alan Murray and edited for what I need it to do but when I run it, I get the windows blue doughnut for a second and that's it. It doesn't error or hang, it simply does nothing.

The task I am trying to accomplish is to:

1. Go into each folder and sub-folder and find a workbook called "*_Budget_*.xlsm".
2. When said file is found, open it and copy only the "BUDGET" worksheet to an existing workbook named "ALL SITES.xls" (...this houses the macro).
3. Since every worksheet is named "BUDGET", I would like to rename each worksheet to whatever is in its own cell "C1"

Any help will be appreciated.

Sub LoopSubfoldersAndFiles()    Dim fso As Object
    Dim folder As Object
    Dim subfolders As Object
    Dim SourceFile As String
    Dim wb As Workbook
    Dim CurrFile As Object


With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder("C:\BUDGET\TEMPLATES\Go_Live")
    Set subfolders = folder.subfolders
    SourceFile = "*_Budget_*.xlsm"
    
    For Each subfolders In subfolders
    
    Set CurrFile = subfolders.Files
        
        For Each CurrFile In CurrFile
            If CurrFile.Name = SourceFile Then
                Set wb = Workbooks.Open(subfolders.Path & "\" & SourceFile)
                    Sheets("BUDGET").Copy After:=Workbooks("ALL SITES.xlsm").Sheets("TOTAL BUDGET")
                    ActiveSheet.[C1] = ActiveSheet.Name
                wb.Close SaveChanges:=False
            End If
        Next
       
    Next
     
    Set fso = Nothing
    Set folder = Nothing
    Set subfolders = Nothing


With Application
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With


End Sub

 

[John_w]

Untested, but try replacing the main loop with:

    For Each subfolders In folder.subfolders
    
        For Each CurrFile In subfolders.Files
            If CurrFile.Name Like SourceFile Then
                Set wb = Workbooks.Open(subfolders.Path & "\" & CurrFile.Name)
                wb.Worksheets("BUDGET").Copy After:=ThisWorkbook.Worksheets("TOTAL BUDGET")
                ActiveSheet.Name = wb.Worksheets("BUDGET").Range("C1").Value
                wb.Close SaveChanges:=False
            End If
        Next
       
    Next

Note that will only look in subfolders 1 level below C:\BUDGET\TEMPLATES\Go_Live. If you want to go lower you will need to restructure the code to call itself (a recursive FileSystemObject procedure).

 

[WWII_Buff]

Thank you John!

...Note that will only look in subfolders 1 level below C:\BUDGET\TEMPLATES\Go_Live. If you want to go lower you will need to restructure the code to call itself (a recursive FileSystemObject procedure).

That went way over my head bro! Can you explain that as if you were talking to a 5th grader

 

[John_w]

My code is the same as yours in that it loops through the immediate subfolders of "C:\BUDGET\TEMPLATES\Go_Live" and the files in those subfolders: for example the subfolders "C:\BUDGET\TEMPLATES\Go_Live\Subfolder1", "C:\BUDGET\TEMPLATES\Go_Live\Subfolder2", etc. Any subfolders of Subfolder1 and Subfolder2 are ignored.

My amended main loop processes the files in the subfolders of a folder (as posted, the main folder). By putting this code in a separate sub-procedure, and specifying a folder path argument instead of the main folder, it can call itself on each subfolder to process the files in the subfolders of those subfolders, until all subfolders have been processed. This is called a recursive procedure.

Here is the complete macro.

Public Sub Copy_All_Budget_Sheets()
    
    Application.ScreenUpdating = False
    ProcessFolder "C:\BUDGET\TEMPLATES\Go_Live"
    Application.ScreenUpdating = True
    MsgBox "Done"
    
End Sub


Private Sub ProcessFolder(folderPath As String)
    
    Static FSO As FileSystemObject
    Dim thisFolder As Folder
    Dim thisFile As File
    Dim subfolder As Folder
    
    If FSO Is Nothing Then Set FSO = New FileSystemObject
    
    Set thisFolder = FSO.GetFolder(folderPath)

    'Process subfolders
    
    For Each subfolder In thisFolder.subfolders
        
        'Loop through files in this folder
        
        For Each thisFile In subfolder.files
            If thisFile.Name Like "*_Budget_*.xlsm" Then
                Copy_Budget_Sheet thisFile.Path
            End If
        Next
        
        ProcessFolder subfolder.Path

    Next

End Sub


Private Sub Copy_Budget_Sheet(workbookFullName As String)
    
    Dim Wb As Workbook
    Dim Ws As Worksheet
    
    Set Wb = Workbooks.Open(workbookFullName)
    If WorksheetExists(Wb, "BUDGET") Then
        Wb.Worksheets("BUDGET").Copy After:=ThisWorkbook.Worksheets("TOTAL BUDGET")
        Set Ws = ActiveSheet
        Ws.Name = Wb.Worksheets("BUDGET").Range("C1").Value
    End If
    Wb.Close saveChanges:=False
    
End Sub


Private Function WorksheetExists(Wb As Workbook, WorksheetName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Wb.Worksheets(WorksheetName).Name <> ""
    On Error GoTo 0
End Function

Note that if you want to also look in *_Budget_*.xlsm files in the main folder, "C:\BUDGET\TEMPLATES\Go_Live", the above code will need tweaking slightly.

 

[WWII_Buff]

Thank you John_w so much!!!!

 

[WWII_Buff]

Hey John_w I am getting a "Compile Error: User-defined type not defined" here:

Static [U]FSO As FileSystemObject[/U]

when I open the module for editing.

 

[John_w]

Add a reference to Microsoft Scripting Runtime, via Tools - References in the VBA editor.

 

[WWII_Buff]

rgr that!
Googling how to do that

 

[WWII_Buff]

Ahhh! Just learned something! Since I will be moving this to SharePoint - I added those too

 

[WWII_Buff]

To bring it full circle - it works! Dude! Thank you so much for your efforts.

I am getting a MS Excel Yes/No box that I am trying to kill by inserting

Application.DisplayAlerts = False

and

Application.DisplayAlerts = True