File listing of all files including subfolders

[mgana]

Is there a way using VBA to list all the files contained in a particular folder which automatically reads through the subfolders of that folder?
The subfolder names should not appear anywhere except in the path of the file name.
The file names have to be in the form of full path including file name with extension.

Please help.

Thanks.

 

[craig schultz]

Hi Benjamin

This code is great but I could really do with it looking down 1 sub folder further? Would really appreciate it if you could help me with this?

Thanks

Craig

Hi ,

Here you go. This code lets you browse to the folder you want to make the list from, it then selects a sheet called file list and starts with making a list of the subfolders and their paths, it then passes the path of the top level folder to a set of code that lists all the files and their path on the same sheet.

You just need to change the sheet name. Let me know if you need any more help.

Sincerely,

Benjamin

Sub ListFolders()
'''''''''''''''''''''''''''''''''''''''Makes List of Folders and Subfolders with paths for copying'''''''''''''''

Dim fs, f, f1, s, sf
Dim iRow As Long
Dim fd As FileDialog
Dim FolderName1 As String

ExtraSlash = "\"

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

With fd
        .AllowMultiSelect = True
        If .Show Then
        
            For Each myFolder In .SelectedItems
                
                   FolderName1 = myFolder & ExtraSlash
    
    
                Set fs = CreateObject("Scripting.FileSystemObject")
                Set f = fs.GetFolder(FolderName1)
                Set sf = f.SubFolders
                
                Sheets("File List").Select
                 Range("A1").Select
                    For Each f1 In sf
                        ActiveCell.Value = f1.Name
                        ActiveCell.Offset(0, 1).Activate
                        ActiveCell.Value = f1.Path ''''''''''''''''''''''''''''''''''''''''''''''''
                        ActiveCell.Offset(0, -1).Activate
                        ActiveCell.Offset(1, 0).Activate
                        'iRow = iRow + 1
                    Next
        
            Next
        End If
End With

ListFiles FolderName1

End Sub

Sub ListFiles(FolderName1 As String)
'''''''''''''''''''''''''''''''''''''''Makes List of Folders and Subfolders with paths for copying'''''''''''''''
    Dim fs As Object
    Dim objFolder As Object
    Dim objFile As Object
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set objFolder = fs.GetFolder(FolderName1)
    
    Sheets("File List").Select  '''change the name of the worksheet selected'''
    Range("a1").Activate
    r = Range("A1").CurrentRegion.Rows.Count
    
    If r = 1 Then
    
      
        For Each objFile In objFolder.Files
            ActiveCell.Select
            Selection.Formula = objFile.Name
            ActiveCell.Offset(0, 1).Select
            Selection.Formula = objFile.Path
            ActiveCell.Offset(0, -1).Select
            ActiveCell.Offset(1, 0).Select
            
        Next
    
    
    Else
    
        Selection.End(xlDown).Select
        ActiveCell.Offset(1, 0).Select
        
        For Each objFile In objFolder.Files
            ActiveCell.Select
            Selection.Formula = objFile.Name
            ActiveCell.Offset(0, 1).Select
            Selection.Formula = objFile.Path
            ActiveCell.Offset(0, -1).Select
            ActiveCell.Offset(1, 0).Select
            
        Next
        
    End If
    
    
    Columns("A").Select
    Selection.Columns.AutoFit
    Range("A1").Select
    
''''''''''''''''''''''''''''''''''''''''''''''''
   
End Sub

 

[AkaTrouble]

have a try with this code

'Force the explicit delcaration of variables
Option Explicit

Sub ListFiles()


    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
    
    'Declare the variables
    Dim objFSO As Scripting.FileSystemObject
    Dim objTopFolder As Scripting.Folder
    Dim strTopFolderName As String
   


    
    'Assign the top folder to a variable
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Pick a folder"
        .Show
        If .SelectedItems.Count = 0 Then MsgBox "Operation Cancelled by the user", vbExclamation + vbOKOnly, "List Files": Exit Sub
        strTopFolderName = .SelectedItems(1)
    End With
    
    ' create a new sheet
    ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count)).Name = Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1)
    
    'Insert the headers for Columns A through F
    Range("A1").Value = "File Name"
    Range("B1").Value = "Ext"
    Range("C1").Value = "File Name"
    Range("D1").Value = "File Size"
    Range("E1").Value = "File Type"
    Range("F1").Value = "Date Created"
    Range("G1").Value = "Date Last Accessed"
    Range("H1").Value = "Date Last Modified"
    Range("I1").Value = "File Path"
    
    
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Get the top folder
    Set objTopFolder = objFSO.GetFolder(strTopFolderName)
    
    'Call the RecursiveFolder routine
    Call RecursiveFolder(objTopFolder, True)
    
    'Change the width of the columns to achieve the best fit
    Columns.AutoFit
    
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).TableStyle = "TableStyleLight1"
    
End Sub

Sub RecursiveFolder(objFolder As Scripting.Folder, _
    IncludeSubFolders As Boolean)

    'Declare the variables
    Dim objFile As Scripting.File
    Dim objSubFolder As Scripting.Folder
    Dim NextRow As Long
    
    'Find the next available row
    NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    'Loop through each file in the folder
    For Each objFile In objFolder.Files
        'to take complete filename in column C  and extract filename without extension lso allowing for fullstops in filename itself
        Cells(NextRow, "A") = "=LEFT(RC[+2],FIND(""#"",SUBSTITUTE(RC[+2],""."",""#"",LEN(RC[+2])-LEN(SUBSTITUTE(RC[+2],""."",""""))))-1)"
        
        
        'to take complete filename from row C and show only its extension
        Cells(NextRow, "B") = "=TRIM(RIGHT(SUBSTITUTE(RC[+1],""."",REPT("" "",LEN(RC[+1]))),LEN(RC[+1])))"
        
        
        Cells(NextRow, "C").Value = objFile.Name
        Cells(NextRow, "D").Value = Format((objFile.Size / 1024 / 1024), "000") & " MB"
        Cells(NextRow, "E").Value = objFile.Type
        Cells(NextRow, "F").Value = objFile.DateCreated
        Cells(NextRow, "G").Value = objFile.DateLastAccessed
        Cells(NextRow, "H").Value = objFile.DateLastModified
        Cells(NextRow, "I").Value = objFile.Path
                
        
        
        NextRow = NextRow + 1
    Next objFile
    
    'Loop through files in the subfolders
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder(objSubFolder, True)
        Next objSubFolder
    End If
    
End Sub

 

[craig schultz]

Hi,

Thanks for your help, I get a 'compile error' and the line below highlighted:

Sub RecursiveFolder(objFolder As Scripting.Folder, _
IncludeSubFolders As Boolean)

When I run it?

The very first code I referenced does everything I need, ie asks me to choose a folder location when I run it. But it only lists files in the top folder & 1 sub folder down, whereas I need it to show 2 sub folders down?

Thanks

Craig

have a try with this code

'Force the explicit delcaration of variables
Option Explicit

Sub ListFiles()


    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
    
    'Declare the variables
    Dim objFSO As Scripting.FileSystemObject
    Dim objTopFolder As Scripting.Folder
    Dim strTopFolderName As String
   


    
    'Assign the top folder to a variable
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "Pick a folder"
        .Show
        If .SelectedItems.Count = 0 Then MsgBox "Operation Cancelled by the user", vbExclamation + vbOKOnly, "List Files": Exit Sub
        strTopFolderName = .SelectedItems(1)
    End With
    
    ' create a new sheet
    ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count)).Name = Mid$(strTopFolderName, InStrRev(strTopFolderName, "\") + 1)
    
    'Insert the headers for Columns A through F
    Range("A1").Value = "File Name"
    Range("B1").Value = "Ext"
    Range("C1").Value = "File Name"
    Range("D1").Value = "File Size"
    Range("E1").Value = "File Type"
    Range("F1").Value = "Date Created"
    Range("G1").Value = "Date Last Accessed"
    Range("H1").Value = "Date Last Modified"
    Range("I1").Value = "File Path"
    
    
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Get the top folder
    Set objTopFolder = objFSO.GetFolder(strTopFolderName)
    
    'Call the RecursiveFolder routine
    Call RecursiveFolder(objTopFolder, True)
    
    'Change the width of the columns to achieve the best fit
    Columns.AutoFit
    
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).TableStyle = "TableStyleLight1"
    
End Sub

Sub RecursiveFolder(objFolder As Scripting.Folder, _
    IncludeSubFolders As Boolean)

    'Declare the variables
    Dim objFile As Scripting.File
    Dim objSubFolder As Scripting.Folder
    Dim NextRow As Long
    
    'Find the next available row
    NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    'Loop through each file in the folder
    For Each objFile In objFolder.Files
        'to take complete filename in column C  and extract filename without extension lso allowing for fullstops in filename itself
        Cells(NextRow, "A") = "=LEFT(RC[+2],FIND(""#"",SUBSTITUTE(RC[+2],""."",""#"",LEN(RC[+2])-LEN(SUBSTITUTE(RC[+2],""."",""""))))-1)"
        
        
        'to take complete filename from row C and show only its extension
        Cells(NextRow, "B") = "=TRIM(RIGHT(SUBSTITUTE(RC[+1],""."",REPT("" "",LEN(RC[+1]))),LEN(RC[+1])))"
        
        
        Cells(NextRow, "C").Value = objFile.Name
        Cells(NextRow, "D").Value = Format((objFile.Size / 1024 / 1024), "000") & " MB"
        Cells(NextRow, "E").Value = objFile.Type
        Cells(NextRow, "F").Value = objFile.DateCreated
        Cells(NextRow, "G").Value = objFile.DateLastAccessed
        Cells(NextRow, "H").Value = objFile.DateLastModified
        Cells(NextRow, "I").Value = objFile.Path
                
        
        
        NextRow = NextRow + 1
    Next objFile
    
    'Loop through files in the subfolders
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder(objSubFolder, True)
        Next objSubFolder
    End If
    
End Sub