VBA Code to List Folders in a Directory

[rhouston08]

I haven't used VBA in about 2 years, and I lost my logical mindset, when it comes to the syntax for programming in Excel. Anywho, I have a make shift code for renaming folder(s), but I need help with VBA to allow me to choose a folder (not subfolder), preferrably in a window, in a specific location, and then just list he folders (and not subfolders) in a spreadsheet. Any assistance is appreciative. Thanks!

 

[Domenic]

The following macro will prompt the user to select a directory, and then list the folders within the directory in a newly created worksheet...

Option Explicit

Sub ListFoldersInDirectory()


    Dim objFSO As Object
    Dim objFolders As Object
    Dim objFolder As Object
    Dim strDirectory As String
    Dim arrFolders() As String
    Dim FolderCount As Long
    Dim FolderIndex As Long


    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Select Folder"
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        strDirectory = .SelectedItems(1)
    End With
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolders = objFSO.GetFolder(strDirectory).SubFolders
    
    FolderCount = objFolders.Count
    
    If FolderCount > 0 Then
        ReDim arrFolders(1 To FolderCount)
        FolderIndex = 0
        For Each objFolder In objFolders
            FolderIndex = FolderIndex + 1
            arrFolders(FolderIndex) = objFolder.Name
        Next objFolder
        Worksheets.Add
        Range("A1").Resize(FolderCount).Value = Application.Transpose(arrFolders)
    Else
        MsgBox "No folders found!", vbExclamation
    End If
    
    Set objFSO = Nothing
    Set objFolders = Nothing
    Set objFolder = Nothing
    
End Sub

Hope this helps!

 

[Leith Ross]

Hello rhouston08,

Here is another method using the Shell Application Object.

Sub ListSubFolders()


    Dim Cell        As Range
    Dim Folder      As Variant
    Dim SubFolders  As Variant
    Dim vArray      As Variant
    
        Set Cell = Range("A1")
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show Then Folder = .SelectedItems(1) Else Exit Sub
        End With
        
        With CreateObject("Shell.Application")
            Set SubFolders = .Namespace(Folder).Items
                SubFolders.Filter 32, "*"
        End With
        
        If SubFolders.Count = 0 Then
            MsgBox "There are No Subfolders in this Directory."
            Exit Sub
        End If
        
        ReDim vArray(1 To SubFolders.Count, 1 To 1)
        
        For n = 0 To SubFolders.Count - 1
            vArray(n + 1, 1) = SubFolders.Item(n).Name
        Next n
        
        With Cell.Resize(n, 1)
            .NumberFormat = "@"
            .Value = vArray
        End With
        
End Sub