List Excel Files in a Folder

daviddiebel
daviddiebel used Ask the Experts™
on
I am trying to develop a macro create a list of all Excel files (not other files types) in a specified folder, including in any subfolders.

It would be ideal if the information would populate two columns in the active workbook running the macro: one column would list the Excel file names, and the other would list the corresponding file path.

I appreciate  any assistance with this!  Thank you.
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Dirk HaestProject manager

Commented:
Code found at http://www.ozgrid.com/forum/showthread.php?t=65530

Sub ListAllFiles() 
    Dim fs As FileSearch, ws As Worksheet, i As Long 
    Set fs = Application.FileSearch 
    With fs 
        .SearchSubFolders = False ' set to true if you want sub-folders included
        .FileType = msoFileTypeAllFiles 'can modify to just Excel files eg with msoFileTypeExcelWorkbooks
        .LookIn = "C:\" 'modify this to where you want to serach
        If .Execute > 0 Then 
            Set ws = Worksheets.Add 
            For i = 1 To .FoundFiles.Count 
                ws.Cells(i, 1) = .FoundFiles(i) 
            Next 
        Else 
            MsgBox "No files found" 
        End If 
    End With 
End Sub 

Open in new window

you need only excel file name ...try this

 
Dim Test, sPath As String
Dim Folder, oFSO As Object
On Error Resume Next
 
Set wbCodeBook = ThisWorkbook
 
sPath = "Your Path"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = oFSO.GetFolder(sPath)
 
With Application.FileSearch
    .NewSearch
     'Change path to suit
    .LookIn = Folder
    .FileType = msoFileTypeExcelWorkbooks
    .SearchSubFolders = False
    .Filename = "*.xls"
    If .Execute > 0 Then 'Workbooks in folder
        For lCount = 1 To .FoundFiles.Count 'Loop through all.
             'This next line should get you the filename of all excel workbooks int he directory
            Workbooks.Name(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
        Next lCount
    End If
End With

refer
http://www.ozgrid.com/forum/showthread.php?t=51306

Sub ListAllXLSFiles()
    Dim lCount As Long
    Dim wbResults As Workbook
    Dim wbCodeBook As Workbook
     
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
     
    On Error Resume Next
     
    Set wbCodeBook = ThisWorkbook
     
    With Application.FileSearch
        .NewSearch
         'Change path to suit
        .LookIn = "C:\Documents and Settings\"
        .FileType = msoFileTypeExcelWorkbooks
         'change filename to suit
        .Filename = "*.xls"
         
        If .Execute > 0 Then 'Workbooks in folder
            For lCount = 1 To .FoundFiles.Count 'Loop through all.
                 'paste filenames to activesheet starting in cell A1
                ActiveSheet.Cells(lCount, 1).Value = .FoundFiles(lCount)
            Next lCount
        End If
    End With
     
    On Error Goto 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

http://www.ozgrid.com/forum/showthread.php?t=75421
Most Valuable Expert 2012
Top Expert 2012
Commented:
Unfortunately, Application.FileSearch has been deprecated in Excel 2007.

Here's an alternative that will work from Excel 2003 forward.  It populates a collection of files, and uses recursion to ascertain files in subfolders as well.  Note, the getFiles() subroutine has an option for file filter (hence "*.xls*" for Excel files) and an option for bSubFolders (TRUE - recurse subfolders, FALSE - just the current folder).  Also, you are prompted to select an initial folder from which to start.

Here's the code:

Sub listAllFiles()
Dim wkb As Workbook
Dim wks As Worksheet
Dim dialogFile As FileDialog
Dim fCol As New Collection
Dim fName As Variant
Dim strPath As String
Dim lastRow As Long
Dim iCnt As Long

    Application.ScreenUpdating = False
    
    Set wkb = ThisWorkbook
    Set wks = wkb.ActiveSheet

    ' Prompt for starting directory
    Set dialogFile = Application.FileDialog(msoFileDialogFolderPicker)
    With dialogFile
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Select starting folder for file listing"
        .Show
    End With
    If dialogFile.SelectedItems.Count > 0 Then
        strPath = dialogFile.SelectedItems(1)
        
        'get collection of files
        Call getFiles(strPath, "*.xls*", fCol, True) '*.xls* will find all excel files in folders/subfolders, starting at the selected path, strPath
        
        'clear worksheet
        lastRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row
        
        If lastRow > 1 Then wks.Range("A2:B" & lastRow).Clear
        
        'output file collection to worksheet
        Application.StatusBar = "Generating Output..."
        For Each fName In fCol
            wks.Range("A2").Offset(iCnt, 0).Value = getPathFromPathFName(CStr(fName))
            wks.Range("A2").Offset(iCnt, 1).Value = getFnameOnly(CStr(fName))
            iCnt = iCnt + 1
        Next fName
        Application.StatusBar = False
        
        Set fCol = Nothing
        
        wks.Range("A:B").EntireColumn.AutoFit
        
        MsgBox "Process Complete!"
    End If
        
    Application.ScreenUpdating = True
    
End Sub
Sub getFiles(strPath, strFilter As String, fCol As Collection, bSubFolders)
Dim FSO As Object
Dim fldr As Object
Dim subFldr As Object
Dim fName As Variant
Dim i As Long

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fldr = FSO.GetFolder(strPath)
    
    Application.StatusBar = "Examining Folder: " & strPath
    On Error Resume Next
    For Each fName In fldr.Files
        If UCase(getFileExt(CStr(fName))) Like UCase(strFilter) Then
            fCol.Add fName
        End If
    Next fName
    If bSubFolders Then
        For Each subFldr In fldr.SubFolders
            Call getFiles(subFldr, strFilter, fCol, True)
        Next subFldr
    End If
    On Error GoTo 0
    Application.StatusBar = False
End Sub
Public Function getFileExt(fName As String) As String
Dim i As Integer

    i = InStr(StrReverse(fName), ".")
    getFileExt = StrReverse(Left(StrReverse(fName), i))
End Function
Public Function getPathFromPathFName(strPath As String) As String
    getPathFromPathFName = Left(strPath, Len(strPath) - InStr(StrReverse(strPath), "\") + 1)
End Function
Public Function getFnameOnly(strPath As String) As String
    getFnameOnly = Right(strPath, Len(strPath) - Len(getPathFromPathFName(strPath)))
End Function

Open in new window


See attached.

Dave
listAllFiles-r1.xls

Author

Commented:
Thank you!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial