Macro Issue: Code not detecting all subfolders

[leggylongshanks]

Hi all,

I'm using this piece of code to go through Folders and their Subfolders. It works quite well in going through the first folder and its sub's but does not seem to generate a full list. Maybe someone with a more experience will be able to see what is causing this.

I am looking for specific files in these folders, and depending in what folder I place the file, it may or may not detect it. I require the code to go at least 3 levels deep (sometimes more).

FolderName = "C:\test folder"
ProcessFiles FolderName, "*.xls"

'~~> This function was taken from
'~~> http://www.vbaexpress.com/kb/getarticle.php?kb_id=245
Sub ProcessFiles(strFolder As String, strFilePattern As String)
    Dim strFileName As String, strFolders() As String
    Dim i As Long, iFolderCount As Long


    '~~> Collect child folders
    On Error Resume Next
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        End If
        strFileName = Dir$()
    Loop


    '~~> process files in current folder
    strFileName = Dir$(strFolder & "\" & strFilePattern)
    Do Until strFileName = ""
        wbCount = wbCount + 1
        ReDim Preserve wbList(1 To wbCount)
        wbList(wbCount) = strFolder & "\" & strFileName
        strFileName = Dir$()
    Loop


    '~~> Look through child folders
    For i = 0 To iFolderCount - 1
        ProcessFiles strFolders(i), strFilePattern
    Next i
End Sub

 

[patel45]

try this

Sub ListSubfoldersFile()
Dim StrFile As String
   Dim objFSO, destRow As Long
   Dim mainFolder, mySubFolder
   arow = 2
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   mFolder = "D:\test\" ' <<<<< to be changed
   Set mainFolder = objFSO.GetFolder(mFolder)
   StrFile = Dir(mFolder & "*.xls*")
   Do While Len(StrFile) > 0
     Cells(arow, 1).Value = mFolder & StrFile
     arow = arow + 1
     StrFile = Dir
   Loop
   For Each mySubFolder In mainFolder.SubFolders
     StrFile = Dir(mySubFolder & "\*.xls*")
     Do While Len(StrFile) > 0
        Cells(arow, 1).Value = mySubFolder & "\" & StrFile
        arow = arow + 1
        StrFile = Dir
     Loop
   Next
End Sub

 

[leggylongshanks]

Thanks for the response.

Your code seems to go into subfolders and return the name of any .xls files, that part works fine. However, if there are any .xls files in that folder, it will not search any of the subfolders also in that folder.

The code I posted does do what I need it to, there may just be some logic flaw or hole somewhere that is causing it to not fully search through the specified folder.

 

[patel45]

Sub ListSubfoldersFile1()
Dim StrFile As String
   Dim objFSO, destRow As Long
   Dim mainFolder, mySubFolder
   arow = 2
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   mFolder = "D:\DATI\prova\"
   Set mainFolder = objFSO.GetFolder(mFolder)
   StrFile = Dir(mFolder & "*.xls*")
   If Len(StrFile) > 0 Then
     Do While Len(StrFile) > 0
       Cells(arow, 1).Value = mFolder & StrFile
       arow = arow + 1
       StrFile = Dir
     Loop
     Exit Sub
   Else
     For Each mySubFolder In mainFolder.SubFolders
       StrFile = Dir(mySubFolder & "\*.xls*")
       If Len(StrFile) > 0 Then
         Do While Len(StrFile) > 0
           Cells(arow, 1).Value = mySubFolder & "\" & StrFile
           arow = arow + 1
           StrFile = Dir
         Loop
         Exit Sub
       End If
     Next
   End If
End Sub