Populating a table with a list of all folders and subfolders

trishcollins

Board Regular
Joined
Jan 7, 2006
Messages
71
Okay, I have managed to almost get this cracked, but currently I am only getting the immediate subfolder names. I am trying to figure out how to get all the subfolder and their subfolder names into a list, so it can be used in a drop down menu on another sheet, so someone can generate a list of files names on that specific subfolder (that is already working, but I want the drop down menu to allow them to "pick" the subfolder name rather than type it in a make mistakes).

Here is the result of the current macro. As you can see each corresponding table only contains the root list of subfolders. The code takes the table on the far left ("EA_Libraries_Data") which contains a list of the other three tables in the first column and the mapped drive for each in the second column, and puts them into an array, then runs through the array, populating the respective table using the mapped drive. I am just missing a loop to get it to go into further subfolders, but can't figure it out. I feel I need to append each subfolder name it finds to MyArrayDir and then run the loop again, but can't figure out the code to do that.



Here is the code:
Code:
Sub ListMyDir()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = True
    Application.StatusBar = "Importing Beehive Directories"
    Dim tblrow As Integer
    Dim myTable As ListObject
    Dim MyArray As Variant
    Dim MyArrayTable As String
    Dim MyArrayDir As String
    Dim x As Integer
    Set myTable = ActiveSheet.ListObjects("EA_Libraries_Data")
    MyArray = myTable.DataBodyRange
    On Error Resume Next
[B]    For x = 1 To 3
    tblrow = 1
    MyArrayTable = MyArray(x, 1)
    MyArrayDir = MyArray(x, 2)
    ActiveSheet.ListObjects(MyArrayTable).DataBodyRange.Delete
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(MyArrayDir)
    On Error Resume Next
    For Each MySubfolder In mySource.SubFolders
    ActiveSheet.ListObjects(MyArrayTable).ListRows.Add AlwaysInsert:=True
        ActiveSheet.ListObjects(MyArrayTable).DataBodyRange(tblrow, 1).Value = MySubfolder
        tblrow = tblrow + 1
    Next
    Next x[/B]
End Sub
 
Last edited:
I figured it out. So, here is the code:

Code:
Sub ListMyDir()
'This updates the tables in the "Starting Directory List" so they can be used in the drop down menus
'on the other worksheets to select a starting directory to list files from
'Setup display defaults
'    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = True
    Application.StatusBar = "Importing Beehive Directories"
'Setup variables
    Dim tblrow As Integer
    Dim myTable As ListObject
    Dim MyArray As Variant
    Dim MyArrayTable As String
    Dim MyArrayPath As String
    Dim x As Integer
    Dim y As Long
'Copy the table of table names and corresponding drive letters into an array
    Set myTable = ActiveSheet.ListObjects("EA_Libraries_Data")
    y = myTable.ListRows.Count
    MyArray = myTable.DataBodyRange
    MsgBox "Number of Tables to Populate:  " & y
    On Error Resume Next
'Loop through list of tables
    For x = 1 To y
    'Set starting row number for table
        tblrow = 1
    'Set the table name and directory
        MyArrayTable = MyArray(x, 1)
        MyArrayPath = MyArray(x, 2)
        MsgBox "Table:  " & MyArrayTable & "  Path:  " & MyArrayPath & "  Row:  " & tblrow
    'Empty the existing table contents
'        ActiveSheet.ListObjects(MyArrayTable).ListRows.Add AlwaysInsert:=True
'        ActiveSheet.ListObjects(MyArrayTable).DataBodyRange.Delete
    'Get directory information
'        Set MyObject = New Scripting.FileSystemObject
'        Set mySource = MyObject.GetFolder(MyArrayPath)
    'Call Subroutine for every instance of a new subfolder
        Call ListDirPath(MyArrayPath, MyArrayTable, tblrow)
    Next x
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = ""
    Application.Calculation = xlCalculationAutomatic
End Sub
Sub ListDirPath(MyArrayPath As String, MyArrayTable As String, tblrow As Integer)
'Get directory information
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(MyArrayPath)
'Add Path to table
        ActiveSheet.ListObjects(MyArrayTable).ListRows.Add AlwaysInsert:=True
        ActiveSheet.ListObjects(MyArrayTable).DataBodyRange(tblrow, 1).Value = MyArrayPath
        tblrow = tblrow + 1
'Loop through all subdirectories
    On Error GoTo MyErr
    For Each MySubfolder In mySource.SubFolders
        Call ListDirPath(MySubfolder.Path, MyArrayTable, tblrow)
    Next
    Exit Sub
MyErr:
   MsgBox Err & ": " & Error(Err)
Exit Sub
End Sub
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top