Get all files in a folder and subfolders

Question

I want to do the following:

Prompt user to choose a folder
Loop through folder (and subfolders if they exist)
Get all .xlsx files
Get specific column from those files (all have the same structure) and combine data from that column

I get all subfolders and all files but I get 5 times as much as I should.

L column is where I get all my data and Insert into Identical Master File (into L column).
I have 5 files - I should get 5 items in the last column, I simply add new folder in it, and same files(copied), so now I should get 10 items in the last column, instead I get 50.

Sub LoopThroughFolder()

    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Rws As Long, Rng As Range, r As Range
    Set Wb = ThisWorkbook: Wb.Sheets(2).Range("L:L").ClearContents
    Dim FSO As Object, fld As Object, Fil As Object
    Dim wbkCS As Workbook
    Dim FolderPath As String
    Dim fsoFile As Object
    Dim fsoFol As Object
    Dim fileName As String
    Dim sWb As Workbook
    Dim MatchingColumn As Range
    Dim MatchingRowNb As Long
    
    MsgBox "Choose a folder: "
    Application.DisplayAlerts = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\Users\"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "No folder selected! Exiting script."
            Exit Sub
        End If
        FolderPath = .SelectedItems(1)
    End With
    If Right(FolderPath, 1) <> "\" Then
        FolderPath = FolderPath + "\"
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(FolderPath)
    If FSO.FolderExists(fld) Then
        For Each fsoFol In FSO.GetFolder(FolderPath).SubFolders
            For Each fsoFile In fsoFol.Files
                If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xlsx" Then
                    fileName = fsoFile.Name
                    Application.ScreenUpdating = False

                    MyDir = FolderPath 'fld
                    fileName = Dir(MyDir & "*.xlsx")
                    ChDir MyDir
                    Application.ScreenUpdating = False
                    Application.DisplayAlerts = False
                    Do While fileName <> ""
                        Set sWb = Workbooks.Open(fileName)
                        With sWb.Worksheets(2)
                            Rws = .Cells(Rows.Count, 12).End(xlUp).Row
                            Set Rng = Range(.Cells(5, 1), .Cells(Rws, 12))
                        End With
                        With Wb.Worksheets(2)
                            Set MatchingColumn = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
                            For Each r In Rng.Rows
                                If r.Cells(1, 1).Value2 <> vbNullString Then 'Ignoring empty rows   
                                    If r.Rows.Hidden = False Then
                                        'We find the row where the Ids matche
                                        MatchingRowNb = Application.Match(r.Cells(1, 1).Value2, MatchingColumn, False)
                                        'We add the current value in the cell with the new value comming from the other file
                                        .Cells(4 + MatchingRowNb, 12).Value2 = .Cells(4 + MatchingRowNb, 12).Value2 + r.Cells(1, 12).Value2
                                    End If
                                End If
                            Next
                        End With
                        sWb.Close SaveChanges:=True
                        Application.DisplayAlerts = True
                        fileName = Dir()
                    Loop
                End If
            Next
        Next
    End If
End Sub

It's pretty hard to review code when it's double/triple-spaced: too much scrolling... — Tim Williams, Aug 11 '20 at 06:16
Does this answer your question? [Is it possible to list all the files and folders in a custom directory - excel vba](https://stackoverflow.com/questions/33893133/is-it-possible-to-list-all-the-files-and-folders-in-a-custom-directory-excel-v) — braX, Aug 11 '20 at 07:32
@braX unfortunately it does not. Pintxo would you mind to specify? — Tahir Ruzbaev, Aug 11 '20 at 12:07

Tim Williams · Accepted Answer · 2020-08-11T20:33:26.347

You're using both FSO and Dir() to loop over the files, so that's why you're getting the same files over and over.

When your sub ends up doing a bunch of things (particularly when one thing is nested in another, and so on) then it's best to consider splitting it up, so you can concentrate on the one thing that's giving you problems, without all the other things "getting in the way".

Here's a stripped-down version to show what I mean. It works but for clarity doesn't have your file processing code.

Option Explicit

Sub LoopThroughFolder()

    Dim Wb As Workbook, sWb As Workbook
    Dim FolderPath As String
    Dim colFiles As Collection, f

    'get a folder
    FolderPath = ChooseFolder()
    If Len(FolderPath) = 0 Then
        MsgBox "No folder selected: exiting"
        Exit Sub
    End If
    
    'find all excel files in subfolders of that folder
    Set colFiles = FileMatches(FolderPath, "*.xlsx")
    If colFiles.Count = 0 Then
        MsgBox "No xlsx files found"
        Exit Sub
    End If
    
    Set Wb = ThisWorkbook
    Wb.Sheets(2).Range("L:L").ClearContents
    
    'loop over the files we found
    For Each f In colFiles
        Set sWb = Workbooks.Open(f.Path)
        'process the file here
        sWb.Close SaveChanges:=True
    Next f
    
End Sub

Function ChooseFolder() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Choose a folder"
        .InitialFileName = "C:\Users\"
        .AllowMultiSelect = False
        If .Show = -1 Then
            ChooseFolder = .SelectedItems(1)
            If Right(ChooseFolder, 1) <> "\" Then _
                       ChooseFolder = ChooseFolder + "\"
        End If
    End With
End Function

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function FileMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    
    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        For Each f In fldr.Files 'get files in folder
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f
        If subFolders Then 'get subfolders for processing?
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
    Loop
    Set FileMatches = colFiles
End Function

Thank you very much! I got rid off the Do .... Loop and adjusted my file handling everything went smoothly. — Tahir Ruzbaev, Aug 12 '20 at 06:02

Get all files in a folder and subfolders

1 Answers1