VBA Folder Structure -- Loop Once

[cwhaley1]

Hi all, I need Excel to list all of the folders in a stated network location and then - in the next column - list all of the subfolders within them, but only to one subfolder level.

I have been using this code for a while, found on Mr. Excel a couple of years ago and originally submitted by John_w. I have made minor changes.

This code is great as it will loop through each and every subfolder, adding it to the sheet, but the folder structure has grown considerably since I first set this up and I now only need the first level of folders listed.

I cannot figure out how to stipulate in VBA that the loop should end after the first sub folder is listed, and then move onto the next folder at that subfolder level. In basic terms, the output should be -- column A showing the root folder, and column B listing folders contained at the next level. Something like the attached snapshot.

This is the code:

Option Explicit

Public Sub Main_List_Folders_and_Files()

    With ActiveSheet
        .Cells.Clear
        List_Folders_and_Files "insert location here, removed for online forum", .Range("A3")
    End With

End Sub


Private Function List_Folders_and_Files(folderPath As String, destCell As Range) As Long

    Dim FSO As Object
    Dim FSfolder As Object, FSsubfolder As Object, FSfile As Object
    Dim folders As Collection, levels As Collection
    Dim subfoldersColl As Collection
    Dim n As Long, c As Long, i As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folders = New Collection
    Set levels = New Collection
    
    'Add start folder to stack'''''''''''''''''''''
    
    folders.Add FSO.GetFolder(folderPath)
    levels.Add 0
       
    n = 0

    Do While folders.Count > 0
    
        'Remove next folder from top of stack'''''''''''''''
        
        Set FSfolder = folders(folders.Count): folders.Remove folders.Count
        c = levels(levels.Count): levels.Remove levels.Count
        
        'Output this folder and its files'''''''''''''''''''''
        
        destCell.Offset(n, c).Value = "'" & FSfolder.Name
        n = n + 0
        c = c + 1
        For Each FSfile In FSfolder.Files
            destCell.Offset(n, c).Value = "'" & FSfile.Name
            n = n + 1
        Next
               
        'Get collection of subfolders in this folder ''
        
        Set subfoldersColl = New Collection
       For Each FSsubfolder In FSfolder.SubFolders
       subfoldersColl.Add FSsubfolder
        Next
        
        'Loop through collection in reverse order and put each subfolder on top of stack.  As a result, the subfolders are processed and
        'output in the correct ascending ASCII order
        
        For i = subfoldersColl.Count To 1 Step -1
            If folders.Count = 0 Then
                folders.Add subfoldersColl(i)
                levels.Add c
            Else
                folders.Add subfoldersColl(i), , , folders.Count
                levels.Add c, , , levels.Count
            End If
        Next
        Set subfoldersColl = Nothing
            
    
   Loop
    
    List_Folders_and_Files = n

End Function

 

[rlv01]

Maybe something like this (note that the code you posted does not just list folders, it also lists the files in those folder - and I did not change that).

Private Function List_Folders_and_Files(folderPath As String, destCell As Range) As Long
    Dim MaxFolderLevel As Long
    MaxFolderLevel = 2
  
    Dim FSO As Object
    Dim FSfolder As Object, FSsubfolder As Object, FSfile As Object
    Dim folders As Collection, levels As Collection
    Dim subfoldersColl As Collection
    Dim n As Long, c As Long, i As Long
  
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folders = New Collection
    Set levels = New Collection
  
    'Add start folder to stack'''''''''''''''''''''
  
    folders.Add FSO.GetFolder(folderPath)
    levels.Add 0
  
    n = 0
  
    Do While folders.Count > 0
      
        'Remove next folder from top of stack'''''''''''''''
      
        Set FSfolder = folders(folders.Count): folders.Remove folders.Count
        c = levels(levels.Count): levels.Remove levels.Count
      
        'Output this folder and its files'''''''''''''''''''''
      
        destCell.Offset(n, c).Value = "'" & FSfolder.Name
        n = n + 0
        c = c + 1
      
        If c <= MaxFolderLevel Then
            For Each FSfile In FSfolder.Files
                destCell.Offset(n, c).Value = "'" & FSfile.Name
                n = n + 1
            Next
          
            'Get collection of subfolders in this folder ''
          
            Set subfoldersColl = New Collection
            For Each FSsubfolder In FSfolder.SubFolders
                subfoldersColl.Add FSsubfolder
            Next
          
            'Loop through collection in reverse order and put each subfolder on top of stack.  As a result, the subfolders are processed and
            'output in the correct ascending ASCII order
          
            For i = subfoldersColl.Count To 1 Step -1
                If folders.Count = 0 Then
                    folders.Add subfoldersColl(i)
                    levels.Add c
                Else
                    folders.Add subfoldersColl(i), , , folders.Count
                    levels.Add c, , , levels.Count
                End If
            Next
            Set subfoldersColl = Nothing
        End If
      
    Loop
  
    List_Folders_and_Files = n
  
End Function

 

[cwhaley1]

Thank you, that’s worked 100%. If I understand it correctly, it’s taking the first subfolder level as the “MaxFolderLevel” in this bit of code:

If c <= MaxFolderLevel Then
For Each FSfile In FSfolder.Files
destCell.Offset(n,

I have removed the lines which recall the file names as well, as this is no longer needed. I’m now going to allow the user to specify the root directory by entering it into a cell rather than within the code.

Thanks again for solving this.