Populating a table with a list of all folders and subfolders

[trishcollins]

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:

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

 

[trishcollins]

Can't input the image of the screen shot, sorry.

 

[trishcollins]

I figured it out. So, here is the 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