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

 

[WWII_Buff]

Done! Thank you again John_w!

 

[WWII_Buff]

....You already answered my question.