Solved

Excel VBA macro to recurse folder

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

NAS Cloud Backup Strategies

This article explains backup scenarios when using network storage. We review the so-called “3-2-1 strategy” and summarize the methods you can use to send NAS data to the cloud

Question has a verified solution.

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

If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
Learn how to make your own table of contents in Microsoft Word using paragraph styles and the automatic table of contents tool. We'll be using the paragraph styles in Word’s Home toolbar to help you create a table of contents. Type out your initial …
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

773 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