Script to loop thru a number of folders and pulling particular cells into a master sheet

[santa12345]

Hello. I used to have a VB script that worked with Excel..years ago.
I now have Office 365 and want to do the following.
Loop thru a number of folders and pull particular cells from particular tabs and import them into a master file.

For example .... folder layout is ....

main folder (static name)

c:\source files

main subfolders (static name)

c:\source files\audi
C:\source files\bmw
c:\source files\buick
c:\source files\chevy

under the main subfolders there will be additional sub folders (these folder names will vary as I have 1000's of them)

for this example lets say under the main sub folder audi, there is a car1, car2, and car3 sub subfolder.

sub subfolders
c:\source files\audi\car1
06182024.xls
06192024.xls
c:\source files\audi\car2
c:\source files\audi\car3

within the car1 subfolder and every subfolder, there will be 2 excel files, I want to open up the most recent (date wise) xls file (06182024.xls) and copy ..lets say sheet1.. cell A1 & A2 to a master xls file, sheet1, cell A1&A2.. . Close that file and move to the next sub subfolder. Repeat. Once the last sub subfolder within audi has been copied (car3 subfolder in this case).... move to the main subfolder (bmw)...etc... and keep going.

There will not be any .xls files in the main subfolders (audi, bmw, etc..) only under the sub subfolders.

Hopefully i've outlined this clearly, if not, please let me know.
Thank you for reading and any assistance you can provide would be greatly appreciated.

 

[AlphaFrog]

Try this. I don't have Office 365 to test it with.

Sub Consolidate_Data()
   
    Const MainPath As String = "C:\source files\"  'Path of main folder
    Dim fsoSubfolder1 As Object
    Dim fsoSubfolder2 As Object
    Dim fsoFile(0 To 2) As Object
    Dim fsoFileMostRecent As Object
    Dim n As Integer
    Dim RowNum As Long: RowNum = 0
    Dim counter As Long
   
    Application.ScreenUpdating = False
    For Each fsoSubfolder1 In CreateObject("Scripting.FileSystemObject").GetFolder(MainPath).SubFolders
        For Each fsoSubfolder2 In fsoSubfolder1.SubFolders
            If fsoSubfolder2.Files.Count = 2 Then
                Erase fsoFile()
                n = 1
                For Each fsoFile(0) In fsoSubfolder2.Files
                    Set fsoFile(n) = fsoFile(0)
                    n = n + 1
                    If n > 2 Then Exit For
                Next fsoFile(0)
                If fsoFile(1).DateLastModified > fsoFile(2).DateLastModified Then
                    Set fsoFileMostRecent = fsoFile(1)
                Else
                    Set fsoFileMostRecent = fsoFile(2)
                End If
                If fsoFileMostRecent.Name Like "*.xls*" Then
                    With Workbooks.Open(fsoFileMostRecent)
                        ThisWorkbook.Sheets(1).Range("A1:B1").Offset(RowNum).Value = .Sheets(1).Range("A1:B1").Value
                        RowNum = RowNum + 1
                        counter = counter + 1
                        .Close SaveChanges:=False
                    End With
                End If
            End If
        Next fsoSubfolder2
    Next fsoSubfolder1
    Application.ScreenUpdating = True
   
    MsgBox counter & " files copied.", vbInformation, "File Copy Complete"
   
End Sub

 

[Fuji]

Different method

Sub test()
    Dim myDir As String, temp(), myList, myExtension As String
    Dim SearchSubFolders As Boolean
    myDir = "c:\source files\"
    myExtension = "########*.xls*"
    SearchSubFolders = True
    myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders)
    If IsError(myList) Then MsgBox "No file found": Exit Sub
    GetData myList
End Sub
 
Function SearchFiles(myDir As String _
    , myFileName As String, n As Long, myList() _
    , Optional SearchSub As Boolean = False) As Variant
    Dim fso As Object, myFolder As Object, myFile As Object, x(1 To 2)
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.GetFolder(myDir).Files
        x(1) = 0
        If (Not myFile.Name Like "~$*") _
            * (UCase(myFile.Name) Like UCase("*" & myFileName)) Then
            If x(1) = 0 Then
                x(1) = Val(myFile.Name): x(2) = myFile.Name
            Else
                If Val(myFile.Name) > x(1) Then
                    x(1) = Val(myFile.Name): x(2) = myFile.Name
                End If
            End If
        End If
    Next
    If x(1) <> "" Then
        n = n + 1
        ReDim Preserve myList(1 To 2, 1 To n)
        myList(1, n) = myDir
        myList(2, n) = x(2)
    End If
    If SearchSub Then
        For Each myFolder In fso.GetFolder(myDir).SubFolders
            SearchFiles = SearchFiles(myFolder.Path, myFileName, _
            n, myList, SearchSub)
        Next
    End If
    SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function

Sub GetData(myList)
    Dim i As Long, wsName As String
    Application.ScreenUpdating = False
    With ThisWorkbook.Sheets(1)
        .Columns("a:e").ClearContents
        .[a1:e1] = Array("A1 value", "A2 value", "Folder Name", "File Name", "Sheet Name")
        For i = 1 To UBound(myList, 2)
            If Dir(myList(1, i) & "\" & myList(2, i)) <> "" Then
                wsName = GetFirstSheetName(myList(1, i) & "\" & myList(2, i))
                With .Range("a" & Rows.Count).End(xlUp)(2)
                    .Resize(, 2).Formula = Array("='" & myList(1, i) & "\[" & myList(2, i) & "]" & wsName & "'!a1", _
                        "='" & myList(1, i) & "\[" & myList(2, i) & "]" & wsName & "'!a2")
                    .Columns(3).Resize(, 3) = Array(myList(1, i), myList(2, i), wsName)
                End With
            End If
        Next
        .[a1].CurrentRegion.Value = .[a1].CurrentRegion.Value
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Function GetFirstSheetName(fn As String) As String
    With CreateObject("DAO.DBEngine.120").workspaces(0).OpenDatabase(fn, True, True, "excel 12.0;HDR=No;")
        GetFirstSheetName = Replace(.tabledefs(0).Name, "'", "")
        GetFirstSheetName = Left$(GetFirstSheetName, Len(GetFirstSheetName) - 1)
        .Close
    End With
End Function

 

[santa12345]

thanks for the replies and sorry for the delay in responding.
i would like to test out each of the supplied scenarios.

so for starters..regarding the first solution provided..

@AlphaFrog

i am doing a test. I have 10 files in the first folder and sub folders.
your vb is working but i would like to tweak this line.

modify this line of code ----> ThisWorkbook.Sheets(1).Range("A1:B1").Offset(RowNum).Value = .Sheets(1).Range("A1:B1").Value

within the first source file . i would like to copy the tab (test_data) cells a1 to z1000 onto a master sheet...

and then repeat with the second source file...and so now....

i am grabbing 1000 cells from each source file although most source files will not have 1000 rows of data. there is no static (same # of rows of data to copy).

it can either append 1000 rows per source file or append data to the next available line in the master sheet. either way is fine, whichever is easiest.

if its a simple tweak just to append 1000 lines per file, lets do that.

thank you again.