CODEWITHSUNDEEP
vbaexcelloopsdirectory
SynDuck
SynDuck

Reputation: 47

Trying to loop through subfolders and files within subfolders

I want to access a folder using VBA and loop through all Excel files in all subfolders. More specifically, I want to gather data from specific cells in each file and dump the data in my active workbook. Something i feel should be easy to write up but I've been unsuccessful so far. I've tried a few methods for looping through subfolders that I found online but they haven't helped.

Here's a visual idea of what I'd like to achieve:

Sub example()
'Find a way to enter file path
'Find a way to loop through subfolders
'Find a way to loop through excel files and refer to current file below
x = 2
Workbooks(Loop Test.xlsm).Worksheets("Sheet1").Cells(x,1) = 'current file in loop range A1
Workbooks(Loop Test.xlsm).Worksheets("Sheet1").Cells(x,2) = 'current file in loop range A2
' etc.
x = x + 1
' next file
End Sub

Upvotes: 0

Views: 4076

Answers (2)

TinMan
TinMan

Reputation: 7759

Writing a function to return the list of files will make testing easier.

Test

Sub TestGetFileList()
    Dim f As Variant, fileList As Object
    Set fileList = getFileList("C:\Level 1")
    For Each f In fileList
        Debug.Print f
    Next

End Sub

enter image description here

enter image description here

enter image description here

getFileList:Function

Function getFileList(Path As String, Optional FileFilter As String = "*.xls?", Optional fso As Object, Optional list As Object) As Object
    Dim BaseFolder As Object, f As Object

    If fso Is Nothing Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set list = CreateObject("System.Collections.ArrayList")
        'Set list = CreateObject("Scripting.Dictionary")
    End If

    If Not Right(Path, 1) = "\" Then Path = Path & "\"
    If Len(Dir(Path, vbDirectory)) = 0 Then
        MsgBox Path & " not found"
        Exit Function
    End If

    Set BaseFolder = fso.GetFolder(Path)
    For Each f In BaseFolder.SubFolders
        getFileList f.Path, FileFilter, fso, list
    Next

    For Each f In BaseFolder.files
        If f.Path Like FileFilter Then list.Add f.Path
    Next

    Set getFileList = list
End Function

Upvotes: 1

SynDuck
SynDuck

Reputation: 47

Think I've got it:

Sub Test2()

Dim wb As Workbook, ws As Worksheet
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder("C:\Users\azrae\OneDrive\Desktop\To Be Transferred\Optimum\Test Folder\")
x = 2
For Each sfldr In fldr.SubFolders

    For Each wbfile In sfldr.Files
        If fso.getextensionname(wbfile.Name) = "xlsx" Then
        Set wb = Workbooks.Open(wbfile.Path)
        End If
        Workbooks("Loop Test.xlsm").Worksheets("Sheet1").Cells(x, 1) = wb.Worksheets("Sheet1").Range("A1")
        Workbooks("Loop Test.xlsm").Worksheets("Sheet1").Cells(x, 2) = wb.Worksheets("Sheet1").Range("A2")
        Workbooks("Loop Test.xlsm").Worksheets("Sheet1").Cells(x, 3) = wb.Worksheets("Sheet1").Range("A3")
        wb.Close
        x = x + 1
    Next wbfile
Next sfldr

End Sub

Let me know if you have a smoother method.

Upvotes: 0

Related Questions