VBA to recurse subdirectories and list file information

lionelnz

Well-known Member
Joined
Apr 6, 2006
Messages
568
I am using Win 8.1 and Excel 2013, (64 bit)

I have this macro that worked well on Windows XP and Excel 2003 (32 bit)

It puts file information into a sheet. (well it did but not now.)

I am sure it is to do with References settings in VBA editor.

Can anyone help?

Code:
Option Explicit

'created using John Walkenbach's "Microsoft Excel 2000 Power
'  Programming with VBA" example as a basic starting point
'====================================
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
  ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
  As Long
  
'=====================================
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
'=====================================
Public Sub ListFilesToWorksheet()
On Error Resume Next
    'History:
    ' 07/15/2000 added hyperlink
    ' 07/17/2000 added filename filter
    ' 07/20/2000 added # files found info & criteria info
    ' 07/27/2000 added extension as separate column
    ' 08/03/2000 changed # files found to 'count' formula
    ' 10/23/2000 add status bar 'Wait' message
    Dim aryHiddensheets()
    Dim blnSubFolders As Boolean
    Dim dblLastRow As Double
    Dim i As Integer, r As Integer, x As Integer
    Dim Y As Integer, iWorksheets As Integer
    Dim msg As String, Directory As String, strPath As String
    Dim strResultsTableName As String, strFileName As String
    Dim strFileNameFilter As String, strDefaultMatch As String
    Dim strExtension As String, strFileBoxDesc As String
    Dim strMessage_Wait1 As String, strMessage_Wait2 As String
    Dim varSubFolders As Variant
    
    '/==========Variables=============
    strResultsTableName = "File_Listing"
    strDefaultMatch = "*.*"
    r = 1
    i = 1
    blnSubFolders = False
    strMessage_Wait1 = "Please wait while search is in progress..."
    strMessage_Wait2 = "Please wait while formatting is completed..."
    '/==========Variables=============
    
    strFileNameFilter = InputBox("Ex:  *.* with find all files" & vbCr & _
        "     blank will find all Office files" & vbCr & _
        "     *.xls will find all Excel files" & vbCr & _
        "     G*.doc will find all Word files beginning with G" & vbCr & _
        "     Test.txt will find only the files named TEST.TXT" & vbCr, _
        "Enter file name to match:", Default:=strDefaultMatch)
                   
    If Len(strFileNameFilter) = 0 Then
        strFileBoxDesc = "All MSOffice files"
      Else
        strFileBoxDesc = strFileNameFilter
    End If
    
    msg = "Look for: " & strFileBoxDesc & vbCrLf & _
        " - Select location of files to be listed or press Cancel."
    Directory = GetDirectory(msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
    
    varSubFolders = _
        MsgBox("Search Sub-Folders of " & Directory & " ?", _
        vbInformation + vbYesNoCancel, "Search Sub-Folders?")
    
    If varSubFolders = vbYes Then blnSubFolders = True
    If varSubFolders = vbNo Then blnSubFolders = False
    If varSubFolders = vbCancel Then Exit Sub
    
    'Count number of worksheets in workbook
    iWorksheets = ActiveWorkbook.Sheets.Count
        
    'redim array
    ReDim aryHiddensheets(1 To iWorksheets)
    
    'put hidden sheets in an array, then unhide the sheets
    For x = 1 To iWorksheets
        If Worksheets(x).Visible = False Then
            aryHiddensheets(x) = Worksheets(x).Name
            Worksheets(x).Visible = True
        End If
    Next
    
    'Check for duplicate Worksheet name
    i = ActiveWorkbook.Sheets.Count
    For x = 1 To i
        If UCase(Worksheets(x).Name) = UCase(strResultsTableName) Then
            Worksheets(x).Activate
            If Err.Number = 9 Then
                  Exit For
            End If
            Application.DisplayAlerts = False       'turn warning messages off
            ActiveWindow.SelectedSheets.Delete
            Application.DisplayAlerts = True        'turn warning messages on
            Exit For
        End If
    Next

    'Add new worksheet at end of workbook
    '   where results will be located
    Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
    
   'Name the new worksheet and set up Titles
    ActiveWorkbook.ActiveSheet.Name = strResultsTableName
    ActiveWorkbook.ActiveSheet.Range("A1").Value = "Hyperlink"
    ActiveWorkbook.ActiveSheet.Range("B1").Value = "Path"
    ActiveWorkbook.ActiveSheet.Range("C1").Value = "FileName"
    ActiveWorkbook.ActiveSheet.Range("D1").Value = "Extension"
    ActiveWorkbook.ActiveSheet.Range("E1").Value = "Size"
    ActiveWorkbook.ActiveSheet.Range("F1").Value = "Date/Time"
    Range("A1:E1").Font.Bold = True
    
    r = r + 1
    
    On Error Resume Next
    Application.StatusBar = strMessage_Wait1
    With Application.FileSearch
        .NewSearch
        .LookIn = Directory
        '.FileName = "*.*"
        .Filename = strFileNameFilter
        '.SearchSubFolders = False
        .SearchSubFolders = blnSubFolders
        .Execute
        For i = 1 To .FoundFiles.Count
            strFileName = ""
            strPath = ""
            For Y = Len(.FoundFiles(i)) To 1 Step -1
                If Mid(.FoundFiles(i), Y, 1) = "\" Then
                    Exit For
                End If
                strFileName = Mid(.FoundFiles(i), Y, 1) & strFileName
            Next Y
            strPath = Left(.FoundFiles(i), Len(.FoundFiles(i)) - Len(strFileName))
            strExtension = ""
            For Y = Len(strFileName) To 1 Step -1
                If Mid(strFileName, Y, 1) = "." Then
                    If Len(strFileName) - Y <> 0 Then
                        strExtension = Right(strFileName, Len(strFileName) - Y)
                        strFileName = Left(strFileName, Y - 1)
                        Exit For
                    End If
                End If
            Next Y
            Cells(r, 1) = .FoundFiles(i)
            ActiveSheet.Hyperlinks.Add anchor:=Cells(r, 1), Address:=.FoundFiles(i)
            Cells(r, 2) = strPath
            Cells(r, 3) = strFileName
            Cells(r, 4) = strExtension
            Cells(r, 5) = FileLen(.FoundFiles(i))
            Cells(r, 6) = FileDateTime(.FoundFiles(i))
            r = r + 1
        Next i
    End With
    
    'formatting
    Application.StatusBar = strMessage_Wait2
    ActiveWindow.Zoom = 75
    Columns("E:E").Select
    With Selection
        .NumberFormat = "_(* #,#[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=0_"]#0_[/URL] );_(* (#,##0);_(* ""-""??_);_(@_)"
    End With
    Columns("F:F").Select
    With Selection
        .HorizontalAlignment = xlLeft
    End With
    Columns("A:F").EntireColumn.AutoFit
    Columns("A:A").Select
    If Selection.ColumnWidth > 12 Then
        Selection.ColumnWidth = 12
    End If
    
    Range("A2").Select
    ActiveWindow.FreezePanes = True
    
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    dblLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
    dblLastRow = dblLastRow + 1
    
    ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
    If Len(strFileNameFilter) = 0 Then
        strFileNameFilter = "All MSOffice products"
    End If
    If blnSubFolders Then
        Directory = "(including Subfolders) - " & Directory
    End If
        
    Application.ActiveCell.Formula = "=COUNTA(A3:A" & dblLastRow & ") & " & Chr(34) & " files(s) found for Criteria: " & Directory & strFileNameFilter & Chr(34)
    Selection.Font.Bold = True
     
    're-hide previously hidden sheets
    On Error Resume Next
    Y = UBound(aryHiddensheets)
    For x = 1 To Y
            Worksheets(aryHiddensheets(x)).Visible = False
    Next
    
    Range("A3").Select
    
Exit_ListFiles:
    Application.StatusBar = False
    Exit Sub
        
Err_ListFiles:
    MsgBox "Error: " & Err & " - " & Err.Description
    Resume Exit_ListFiles
    
End Sub

'=======================================
Function GetDirectory(Optional msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
    bInfo.pidlRoot = 0&

' Title in the dialog
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = msg
  End If

' Type of directory to return
    bInfo.ulFlags = &H1

' Display the dialog
    x = SHBrowseForFolder(bInfo)

' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function
 
Last edited:

Some videos you may like

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

Watch MrExcel Video

Forum statistics

Threads
1,126,928
Messages
5,621,639
Members
415,849
Latest member
PhoenixRising2015

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top