VBA Compiling Data from Multiple Workbooks in Multiple Subfolders

[dhubz]

Hi Everyone,

I will try to explain what I have already and what I am trying to do, here is what I am trying to do;

-I have a blank master sheet(C:\path1\path2\overdue.xlsm) it has column headers and a macro button
-the data pulled from other workbooks will start in row 2
-the macro needs to open an excel file (C:\path1\path2\path3\project1.xlsx)
-check for 2 text criteria
-a "Y" (Static cell B7)
- an "OVERDUE" (Range of cells always starts B16) range of 4+ cells to check
-If it matches both criteria it will copy various cells from the worksheet
-it needs to paste the copied cells but transposed into the next available row on master sheet(C:\path\path\overdue.xlsm)
-then closes the excel file without saving the changes (C:\path1\path2\path3\project1.xlsx)
-it needs to loop this macro through all of the subfolders within (C:\path1\path2\) , each project has its own folder, each folder has its own xlsx file along with other project files(this is why the xlsx files are all in different folders)

I have tried mutliple variations of looping code and recording macros and piecing them together with other code that works but no luck.

Here is the code I found that handles the opening of multiple files within multiple folders, this portion seems to be working fine.

Sub Macro1()    '//Change the path to the main folder, accordingly
    Call RecursiveFolders("C:\Box Sync\LocateRequests\!LOCATES TRACKING\FOR TRACKING\")
End Sub


Sub RecursiveFolders(ByVal MyPath As String)


    Dim FileSys As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
    Dim wkbOpen As Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet


    
    Set FileSys = CreateObject("Scripting.FileSystemObject")
    Set objFolder = FileSys.GetFolder(MyPath)


    Application.ScreenUpdating = False
    
    For Each objSubFolder In objFolder.SubFolders
        For Each objFile In objSubFolder.Files
            Set wkbOpen = Workbooks.Open(filename:=objFile)
            '//Change the name of your macro, accordingly
            Call OVERDUEcheck
            wkbOpen.Close savechanges:=False
        Next
        Call RecursiveFolders(objSubFolder.Path)
    Next
      
    Application.ScreenUpdating = True
    
End Sub

This macro OVERDUEcheck works great when all of the files are in the same folder. I have tried to remove the parts of this code that handle the file open-close-looping, as that part should be now handled by the above code, and just use the functional portion for extracting the data I need, but every time I fix an issue another error pops up.

Sub OVERDUEcheck()    Dim sPath As String, sName As String
    Dim bk As Workbook      'opened from the folder
    Dim src As Worksheet    'sheet to retrieve data from
    Dim sh As Worksheet     'the sheet with the command button
    Dim rw As Long          'the row to write to on sh
    Dim lr As Long          'last row col A of src sheet
    Dim i As Integer        'for looping rows to look at
    
Set sh = ActiveSheet ' I will record the value and workbook name
' in the activesheet when the macro runs


rw = 2 ' which row to write to in the activesheet
sPath = "C:\Box Sync\LocateRequests\!LOCATES TRACKING\FOR TRACKING\" ' Path for file location
sName = Dir(sPath & "*.xls")


Do While sName <> "" 'Loop until filename is blank
    Set bk = Workbooks.Open(sPath & sName)
    Set src = bk.Worksheets(2)
    
    With src
        If .Range("B7").Text = "Y" Then
            lr = .Range("A" & Rows.Count).End(xlUp).Row
            For i = 16 To lr
                If .Cells(i, "B").Text = "OVERDUE" Then
                    sh.Cells(rw, "A") = .Range("b5")
                    sh.Cells(rw, "B") = .Range("b6")
                    sh.Cells(rw, "C") = .Range("b10")
                    sh.Cells(rw, "D") = .Range("b11")
                    sh.Cells(rw, "E") = .Range("a" & i)
                    sh.Cells(rw, "F") = .Range("B12")
                    rw = rw + 1
                End If
            Next i
        End If
    End With
    
    bk.Close SaveChanges:=False
    sName = Dir()
    
Loop ' loop until no more files


End Sub

Thanks in advance, any help/tips would be greatly appreciated.
Dave