# VBA to List all Folders, Subfolders and files in a directory



## acrete

Hi all, I found many examples that prints file directories into a spreadsheet. I am trying to create a VBA in Excel that replicates a cmd  script to list out contents of a folder, subfolders and files



		Code:
__


tree "C:\list\" > C:\list\details.txt" /A /F


The spreadsheet needs to cascade so column A lists the files in the directory, column b lists the subfolders, column c lists the files in the subfolders, column d lists subfolders of the subfolder, etc....

Any help would be much appreciated. Thanks!


----------



## John_w

Try this macro. The usual method of processing folders, files and subfolders is a procedure which calls itself (a recursive procedure), however I decided to use a stack structure implemented as 2 VBA Collections for the folders and folder levels, which are kept in sync.  This avoids the need to use a class module to store both properties.



		VBA Code:
__


Option Explicit

Public Sub Main_List_Folders_and_Files()

    With ActiveSheet
        .Cells.Clear
        List_Folders_and_Files "C:\list", .Range("A1")
    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 + 1
        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


----------



## abdo meghari

@John_w   thanks  for  your  code . just  question  how add  hyperlink   to  open  folder or  subfolder  or file?


----------



## John_w

abdo meghari said:


> just question how add hyperlink to open folder or subfolder or file?


Make these two changes:


		VBA Code:
__


        'destCell.Offset(n, c).Value = "'" & FSfolder.Name  'OLD
        destCell.Worksheet.Hyperlinks.Add Anchor:=destCell.Offset(n, c), Address:=FSfolder.path, TextToDisplay:=FSfolder.Name




		VBA Code:
__


            'destCell.Offset(n, c).Value = "'" & FSfile.Name 'OLD
            destCell.Worksheet.Hyperlinks.Add Anchor:=destCell.Offset(n, c), Address:=FSfile.path, TextToDisplay:=FSfile.Name


----------



## abdo meghari

great ! thank  for  that .


----------



## mrsoliveira

One more question, how to create a column right with date of created folder?

Or How to read directories since root level in this vba:




		VBA Code:
__


Sub sbListAllFolderDetails()
    
    'Disable screen update
    Application.ScreenUpdating = False
    
    'Variable Declaration
    Dim shtFldDetails As Worksheet
    Dim sRootFolderName As String
    
    'Browse Root Folder
    sRootFolderName = sbBrowesFolder & "\"
    
    'If path is not available, it display message and exit from the procedure
    If sRootFolderName = "\" Then
        MsgBox "Please select folder to find list of folders and Subfolders", vbInformation, "Input Required!"
        Exit Sub
    End If
    
    'Delete Sheet if it exists
    Application.DisplayAlerts = False
        On Error Resume Next
        ActiveWorkbook.Sheets("Folder Details").Delete
    Application.DisplayAlerts = True
    
    'Add new Worksheet and name it as 'Folder Details'
    With ThisWorkbook
        Set shtFldDetails = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        shtFldDetails.Name = "Folder Details"
    End With
    
    'Create object for sheet name
    Set shtFldDetails = Sheets("Folder Details")
    
    'Clear Sheet
    shtFldDetails.Cells.Clear
    
    'Main Header and its Fomat
    With shtFldDetails.Range("A1")
        .Value = "Folder and SubFolder Details"
        .Font.Bold = True
        .Font.Size = 12
        .Interior.ThemeColor = xlThemeColorDark2
        .Font.Size = 14
        .HorizontalAlignment = xlCenter
    End With
    
    With shtFldDetails
        'Merge Header cells
        .Range("A1:H1").Merge
    
        'Create Headers
        .Range("A2") = "Folder Path"
        .Range("B2") = "Short Folder Path"
        .Range("C2") = "Folder Name"
        .Range("D2") = "Short Folder Name"
        .Range("E2") = "Number of Subfolders"
        .Range("F2") = "Number of Files"
        .Range("G2") = "Folder Size"
        .Range("H2") = "Folder Create Date"
        
        .Range("A2:H2").Font.Bold = True
    End With
    
    'Call Sub Procedure
    'List all folders & subfolders
    sbListAllFolders sRootFolderName
    
    'Enable Screen Update
    Application.ScreenUpdating = True
    
End Sub

Sub sbListAllFolders(ByVal SourceFolder As String)
    
    'Variable Declaration
    Dim oFSO As Object, oSourceFolder As Object, oSubFolder As Object
    Dim iLstRow As Integer
            
    'Create object to FileSystemObject
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oSourceFolder = oFSO.GetFolder(SourceFolder)
    
    'Define Start Row
    iLstRow = Sheets("Folder Details").Cells(Sheets("Folder Details").Rows.Count, "A").End(xlUp).Row + 1
    
    'Update Folder properties to Sheet
    With Sheets("Folder Details")
        .Range("A" & iLstRow) = oSourceFolder.Path
        .Range("B" & iLstRow) = oSourceFolder.ShortPath
        .Range("C" & iLstRow) = oSourceFolder.Name
        .Range("D" & iLstRow) = oSourceFolder.ShortName
        .Range("E" & iLstRow) = oSourceFolder.SubFolders.Count
        .Range("F" & iLstRow) = oSourceFolder.Files.Count
        .Range("G" & iLstRow) = oSourceFolder.Size
        .Range("H" & iLstRow) = oSourceFolder.datecreated
    End With
        
    'Loop through all Sub folders
    For Each oSubFolder In oSourceFolder.SubFolders
        sbListAllFolders oSubFolder.Path
    Next oSubFolder
    
    'Autofit content in respective columns
    Sheets("Folder Details").Columns("A:H").AutoFit
    
    'Release Objects
    Set oSubFolder = Nothing
    Set oSourceFolder = Nothing
    Set oFSO = Nothing


End Sub

Public Function sbBrowesFolder()
    Dim FldrPicker As FileDialog
    Dim myPath As String
        
    'Browse Folder Path
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    
      With FldrPicker
        .Title = "Browse Root Folder Path"
        .AllowMultiSelect = False
          If .Show <> -1 Then Exit Function
          myPath = .SelectedItems(1)
      End With
 
      sbBrowesFolder = myPath
      If myPath = vbNullString Then Exit Function

End Function



Thanks in advice


----------



## Kdilas

John,
This is an AWESOME Macro, Thank you for sharing with the group! I actually found this post while looking for something else but this solved another issue I needed to address. Thank You again!!


----------



## howeyes

Instead of listing folders in separate columns how can I modify the code to have two columns - one column the complete folder name and the the other the file name?


----------



## John_w

howeyes said:


> Instead of listing folders in separate columns how can I modify the code to have two columns - one column the complete folder name and the the other the file name?



Please start a new thread, referencing this one if necessary, and show exactly the layout you want.


----------



## howeyes

John_w said:


> Please start a new thread, referencing this one if necessary, and show exactly the layout you want.


I found a better solution on your website.


----------



## acrete

Hi all, I found many examples that prints file directories into a spreadsheet. I am trying to create a VBA in Excel that replicates a cmd  script to list out contents of a folder, subfolders and files



		Code:
__


tree "C:\list\" > C:\list\details.txt" /A /F


The spreadsheet needs to cascade so column A lists the files in the directory, column b lists the subfolders, column c lists the files in the subfolders, column d lists subfolders of the subfolder, etc....

Any help would be much appreciated. Thanks!


----------



## jaeiow

@mrsoliveira​


> 'Call Sub Procedure
> 'List all folders & subfolders
> sbListAllFolders sRootFolderName


the following code will list without calling FSO for each subfolder, instead it calls it once.



		VBA Code:
__


Option Explicit

Sub ListAllFoldersForSubFolders()

Dim shtFldDetails As Worksheet
Dim fso As Object
Dim fldr As Object
Dim fldrSF As Object
Dim ofiles As Object
Dim wb As Workbook
Dim wbLinks As Workbook
Dim strPath As String
Dim strMsg As String
Dim strFld As String
Dim lRow As Long
Dim wsZip As Worksheet

'Disable visual updates
Application.Calculation = xlManual
Application.DisplayAlerts = True
Application.ScreenUpdating = False
On Error GoTo errHandler

Dim sRootFolderName As String

m_InitAfterRefresh.resetTableTracking
Sheet5.Unprotect
Range("File_List").Locked = True
m_FindColsandHide.HideColumns

'Browse Root Folder
sRootFolderName = sbBrowesFolder & "\"

'If path is not available, it display message and exit from the procedure
If sRootFolderName = "\" Then
    MsgBox "Please select folder to find and list its contents.", vbInformation, "Input Required!"
    Exit Sub
End If
 
'change sheet and range names
'  to match your workbook
strPath = sRootFolderName

Set wbLinks = ThisWorkbook

strMsg = "Could not start the list"
    'Delete Sheet if it exists
    Application.DisplayAlerts = False
        On Error Resume Next
        wbLinks.Sheets("Folder Details").Delete
    Application.DisplayAlerts = True
 
    'Add new Worksheet and name it as 'Folder Details'
    With wbLinks
        Set shtFldDetails = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        shtFldDetails.Name = "Folder Details"
    End With
 
    'Create object for sheet name
    Set shtFldDetails = Sheets("Folder Details")
 
    'Clear Sheet
    shtFldDetails.Cells.Clear
Set wsZip = shtFldDetails
lRow = 4  'leave rows for heading

Set fso = _
  CreateObject("Scripting.FileSystemObject")
Set fldrSF = fso.GetFolder(strPath)

strMsg = "Could not count folders"
         
If Not fldrSF Is Nothing Then

processFolder fldrSF, strPath, wsZip, lRow

Else
  MsgBox "Could not find main folder"
  GoTo exitHandler
End If

With wsZip
  With .Cells(1, 1)
    .value = "Subfolders - " & strPath
    .Font.Bold = True
    .Font.Size = 14
  End With
  With .Range("B3:C3")
    .value = Array("Folder Path", "Files")
    .Font.Bold = True
  End With
  .Columns("B:C").EntireColumn.AutoFit
End With

strMsg = "List has been created"

exitHandler:
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  MsgBox strMsg

  Exit Sub

errHandler:
    Resume exitHandler

End Sub

Function processFolder(fldr As Object, strPath As String, wsZip As Worksheet, lRow As Long)
    If Not fldr Is Nothing Then
        Dim ofiles As Files
        Set ofiles = fldr.Files
        With wsZip
            .Cells(lRow, 2).value = strPath
            .Cells(lRow, 3).value = ofiles.Count
        End With
        lRow = lRow + 1
        On Error Resume Next
        For Each fldr In fldr.SubFolders
            processFolder fldr, strPath & fldr.Name & "\", wsZip, lRow
        Next fldr
    End If
End Function

Public Function sbBrowesFolder()
    Dim FldrPicker As FileDialog
    Dim MyPath As String
      
    'Browse Folder Path
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
  
      With FldrPicker
        .Title = "Browse Root Folder Path"
        .AllowMultiSelect = False
                  If InitPath <> "" Then
            If Right$(InitPath, 1) <> "\" Then
                InitPath = InitPath & "\"
            End If
            .InitialFileName = InitPath
        Else
            .InitialFileName = "C:\"
        End If
          If .Show <> -1 Then Exit Function
          MyPath = .SelectedItems(1)
      End With
 
      sbBrowesFolder = MyPath
      If MyPath = vbNullString Then Exit Function

End Function


----------

