Solved

Excel VBA macro to recurse folder

Posted on 2012-03-11
4
275 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 41

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 41

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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Recently Microsoft released a brand new function called CONCAT. It's supposed to replace its predecessor CONCATENATE. But how does it work? And what's new? In this article, we take a closer look at all of this - we even included an exercise file for…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
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…

939 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

Need Help in Real-Time?

Connect with top rated Experts

3 Experts available now in Live!

Get 1:1 Help Now