Excel VBA Count number of rows in all files in folders and subfolders

Question

I am trying to add a Do While loop to also output the number of rows in each file found in the folder specified. I am having trouble with it - I keep getting 0 rows with all versions of my code. Below is the original without the row count addition. I am hitting a wall and would love some direction.

Sub ListAllFilesInAllFolders()
 
    Dim MyPath As String, MyFolderName As String, MyFileName As String
    Dim i As Integer, F As Boolean
    Dim objShell As Object, objFolder As Object, AllFolders As Object, AllFiles As Object
    Dim MySheet As Worksheet
     
    On Error Resume Next
     
    '************************
    'Select folder
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = objFolder.self.Path & ""
    Else
        Exit Sub
       MyPath = "D:Folder"
    End If
    Set objFolder = Nothing
    Set objShell = Nothing
     
    '************************
    'List all folders
     
    Set AllFolders = CreateObject("Scripting.Dictionary")
    Set AllFiles = CreateObject("Scripting.Dictionary")
    AllFolders.Add (MyPath), ""
    i = 0
    Do While i < AllFolders.Count
        Key = AllFolders.keys
        MyFolderName = Dir(Key(i), vbDirectory)
        Do While MyFolderName <> ""
            If MyFolderName <> "." And MyFolderName <> ".." Then
                If (GetAttr(Key(i) & MyFolderName) And vbDirectory) = vbDirectory Then
                    AllFolders.Add (Key(i) & MyFolderName & ""), ""
                End If
            End If
            MyFolderName = Dir
        Loop
        i = i + 1
    Loop
     
    'List all files
    For Each Key In AllFolders.keys
        MyFileName = Dir(Key & "*.*")
        'MyFileName = Dir(Key & "*.PDF")    'only PDF files
        Do While MyFileName <> ""
            AllFiles.Add (MyFileName), Key
            MyFileName = Dir
        Loop
    
    Next
     
    '************************
    'List all files in Files sheet
     
    For Each MySheet In ThisWorkbook.Worksheets
        If MySheet.Name = "Files" Then
            Sheets("Files").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then Sheets.Add.Name = "Files"
 
    'Sheets("Files").[A1].Resize(AllFolders.Count, 1) = WorksheetFunction.Transpose(AllFolders.keys)
    Sheets("Files").[A1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.Items)
    Sheets("Files").[B1].Resize(AllFiles.Count, 1) = WorksheetFunction.Transpose(AllFiles.keys)
    Set AllFolders = Nothing
    Set AllFiles = Nothing
End Sub

I have tried:

Do While MyFileName <> ""

   With MyFileName    
        If IsEmpty(.Range("a" & FirstDataRowInSourceFile)) Then
           NumOfRecordsInSourceFile = 0
        Else
           NumOfRecordsInSourceFile = _
          .Range(.Range("a" & FirstDataRowInSourceFile), .Range("a" & 
          FirstDataRowInSourceFile).End(xlDown)).Rows.Count
       End If
   End With

       If Err.Number > 0 Then
          Err.Clear
          Set sourceRange = Nothing
                    
       On Error GoTo 0

question from:https://stackoverflow.com/questions/66068108/excel-vba-count-number-of-rows-in-all-files-in-folders-and-subfolders

Answer 1

'...
'...
Set AllFolders = CreateObject("Scripting.Dictionary")
Set AllFiles = CreateObject("Scripting.Dictionary")
AllFolders.Add (MyPath), ""
i = 0

Do While i < AllFolders.Count
'...
'...

Immediately after creating the dictionary the Count will be zero, so i < AllFolders.Count will be false and your loop never runs.

This should do it:

Sub ListAllFilesInAllFolders()
 
    Dim i As Long, objFolder As Object, wsFiles As Worksheet
    Dim colFiles As Collection, arrFiles, wb, MyPath As String
    
    Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "", 0, 0)
    If Not objFolder Is Nothing Then
        MyPath = objFolder.self.Path & ""
    Else
        Exit Sub               '????????
        MyPath = "D:Folder"
    End If
    
    Set colFiles = GetMatchingFiles(MyPath, "*.csv")
    Debug.Print "Found " & colFiles.Count & " matching files"
    
    ReDim arrFiles(1 To colFiles.Count, 1 To 3) 'size output array
    Application.ScreenUpdating = False
    For i = 1 To colFiles.Count
        Set wb = Workbooks.Open(colFiles(i), ReadOnly:=True)
        arrFiles(i, 1) = wb.Path
        arrFiles(i, 2) = wb.Name
        arrFiles(i, 3) = wb.Sheets(1).UsedRange.Rows.Count
        wb.Close False
    Next i
    Application.ScreenUpdating = True
    
    On Error Resume Next 'ignore error if no match
    Set wsFiles = ThisWorkbook.Sheets("Files")
    On Error GoTo 0      'stop ignoring errors
    If wsFiles Is Nothing Then
        Set wsFiles = ThisWorkbook.Worksheets.Add()
        wsFiles.Name = "Files"
    End If
    
    wsFiles.Cells.ClearContents
    wsFiles.Range("a2").Resize(colFiles.Count, 3).Value = arrFiles
  
End Sub

'Search beginning at supplied folder root, including subfolders, for
'   files matching the supplied pattern.  Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
    Dim colFolders As New Collection, colFiles As New Collection
    Dim fso As Object, fldr, subfldr, fl
    
    Set fso = CreateObject("scripting.filesystemobject")
    colFolders.Add startPath         'queue up root folder for processing
    
    Do While colFolders.Count > 0 'loop until the queue is empty
        fldr = colFolders(1)      'get next folder from queue
        colFolders.Remove 1       'remove current folder from queue
        With fso.getfolder(fldr)
            For Each fl In .Files
                If UCase(fl.Name) Like UCase(filePattern) Then  'check pattern
                    colFiles.Add fl.Path     'collect the full path
                End If
            Next fl
            For Each subfldr In .subFolders
                colFolders.Add subfldr.Path 'queue any subfolders
            Next subfldr
        End With
    Loop
    Set GetMatchingFiles = colFiles
End Function