[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 366
  • Last Modified:

Excel VBA macro to recurse folder

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
cyberkiwi
Asked:
cyberkiwi
  • 2
  • 2
1 Solution
 
dlmilleCommented:
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
 
cyberkiwiAuthor Commented:
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
 
dlmilleCommented:
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
 
cyberkiwiAuthor Commented:
Thanks a lot for this.
You're a good man.
0

Featured Post

Never miss a deadline with monday.com

The revolutionary project management tool is here!   Plan visually with a single glance and make sure your projects get done.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now