Solved

Excel VBA macro to recurse folder

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

Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

Join & Write a Comment

Suggested Solutions

Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

706 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

18 Experts available now in Live!

Get 1:1 Help Now