Solved

Excel VBA macro to recurse folder

Posted on 2012-03-11
4
300 Views
Last Modified: 2012-06-27
Hi,

Can someone please provide an Excel macro to
a) check if the path in $B$3 exists
b) if it doesn't, prompt for a folder
c) look for all Excel files (.xlsx) in the folder and subfolders
d) list the names in Sheet2!A1 downwards (assume sheet is clear)

Easy poinks.

Regards,
Richard
0
Comment
Question by:cyberkiwi
  • 2
  • 2
4 Comments
 
LVL 42

Expert Comment

by:dlmille
ID: 37707640
As requested.

If directory does not exist, you get prompted otherwise, the results are on Sheet2 column A

Code:
Option Explicit

'Source Adapted from: http://www.ammara.com/access_image_faq/recursive_folder_search.html
Sub chkDirAndList()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksOut As Worksheet
Dim strPath As String
Dim fName As String
Dim colFiles As New Collection
Dim cntFile As Long

    Set wkb = ThisWorkbook
    Set wks = wkb.ActiveSheet
    Set wksOut = wkb.Sheets("Sheet2")
    
    strPath = wks.Range("B3").Value

    If Len(Dir(strPath, vbDirectory)) = 0 Then
        MsgBox "Directory " & strPath & " does NOT exist"
    Else
        wksOut.Cells.Clear
        
        RecursiveDir colFiles, strPath, "*.xlsx", True
    
        Dim vFile As Variant
        For Each vFile In colFiles
            wksOut.Range("A1").Offset(cntFile, 0).Value = vFile
            cntFile = cntFile + 1
        Next vFile

    End If

End Sub
Public Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function


Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

Open in new window


See attached.

Dave
recurseDirs-r1.xls
0
 
LVL 58

Author Comment

by:cyberkiwi
ID: 37707669
Very quick! You're definitely one to watch this year.
However, by "prompt" I meant to prompt for one, rather than "alert" the user that it does not exist.. (most likely scenario is that it is blank on first use).  On subsequent uses, the last used directory is stored there.

Keep up the good work!
0
 
LVL 42

Accepted Solution

by:
dlmille earned 500 total points
ID: 37707679
Thanks, cyberkiwi ;)

Option Explicit

'Source Adapted from: http://www.ammara.com/access_image_faq/recursive_folder_search.html
Sub chkDirAndList()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksOut As Worksheet
Dim strPath As String
Dim fName As String
Dim colFiles As New Collection
Dim cntFile As Long
Dim dialogFile As FileDialog

    Set wkb = ThisWorkbook
    Set wks = wkb.ActiveSheet
    Set wksOut = wkb.Sheets("Sheet2")
    
    strPath = wks.Range("B3").Value
    
   ' Open the file dialog
    Set dialogFile = Application.FileDialog(msoFileDialogFolderPicker)
    With dialogFile
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .InitialFileName = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
        .Title = "Select Directory"
        .Show
    End With
    
    If dialogFile.SelectedItems.Count > 0 Then
        strPath = dialogFile.SelectedItems(1)
        
        wksOut.Cells.Clear
        
        RecursiveDir colFiles, strPath, "*.xlsx", True
    
        Dim vFile As Variant
        For Each vFile In colFiles
            wksOut.Range("A1").Offset(cntFile, 0).Value = vFile
            cntFile = cntFile + 1
        Next vFile
        wks.Range("B3").Value = strPath
    End If
    
End Sub
Public Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function


Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

Open in new window


Cheers,

Dave
recurseDirs-r3.xls
0
 
LVL 58

Author Closing Comment

by:cyberkiwi
ID: 37718326
Thanks a lot for this.
You're a good man.
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

My experience with Windows 10 over a one year period and suggestions for smooth operation
Outlook Free & Paid Tools
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

713 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question