List all folders and sub folders

[scotthannaford1973]

Hi

I have the code below which is not quite working and I cannot work out what I changed!

okay - I have a sheet "Getting Started" which contains a button; when I click onto the button it runs FolderNames which causes a dialogue box to pop up - in this box, the user then navigates to a folder and when they click onto OK, it lists all of the folders and sub folders and the folder path. It needs to list this information on an existing sheet in the same workbook, called "Folders". This lists some, but not all of the folders and sub folders in thee selected location. It was working but I then started playing around without saving a backup! I cannot see what to add/change in the code.

i. so, search a parent folder location to list all sib folders
ii. dump results (folder name and path) in an existing folder "Folders"

TIA!

Sub FolderNames()
'Update 20141027
Application.ScreenUpdating = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    .Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Application.Workbooks.Add
Set xWs = Application.ActiveSheet
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Path", "Dir", "Name", "Date Created", "Date Last Modified")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In prntfld.SubFolders
    xRow = Range("A1").End(xlDown).Row + 1
    Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path, Left(SubFolder.Path, InStrRev(SubFolder.Path, "\")), SubFolder.Name, SubFolder.DateCreated, SubFolder.DateLastModified)
Next SubFolder
For Each subfld In prntfld.SubFolders
    getSubFolder subfld
Next subfld
Worksheets("Getting Started").Activate


End Sub

 

[alansidman]

Maybe this. I have used this in the past.

Sub ListAllFile()

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim ws As Worksheet
    Dim sPath As String
    Dim lrA As Long
    Dim lrB As Long

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = Worksheets.Add

    'Get the folder object associated with the directory
    sPath = InputBox("What is the full Path to Search?")
    Set objFolder = objFSO.GetFolder(sPath)
    ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
    ws.Cells(1, 2).Value = "The files found have modified dates:"
    ws.Cells(1, 3).Value = "The file Size is:"

    'Loop through the Files collection
    For Each objFile In objFolder.Files
    'If objFile.Name Like "*.pdf" Then
        lrA = Range("A" & Rows.Count).End(xlUp).Row
        lrB = Range("B" & Rows.Count).End(xlUp).Row
        ws.Range("A" & lrA + 1).Value = objFile.Name
        ws.Range("B" & lrB + 1).Value = objFile.DateLastModified
        ws.Range("C" & lrB + 1).Value = objFile.Size
    'End If
    Next
    'ws.Cells(2, 1).Delete
    'Clean up!
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing

End Sub

 

[scotthannaford1973]

Maybe this. I have used this in the past.

Sub ListAllFile()

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim ws As Worksheet
    Dim sPath As String
    Dim lrA As Long
    Dim lrB As Long

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = Worksheets.Add

    'Get the folder object associated with the directory
    sPath = InputBox("What is the full Path to Search?")
    Set objFolder = objFSO.GetFolder(sPath)
    ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & " are:"
    ws.Cells(1, 2).Value = "The files found have modified dates:"
    ws.Cells(1, 3).Value = "The file Size is:"

    'Loop through the Files collection
    For Each objFile In objFolder.Files
    'If objFile.Name Like "*.pdf" Then
        lrA = Range("A" & Rows.Count).End(xlUp).Row
        lrB = Range("B" & Rows.Count).End(xlUp).Row
        ws.Range("A" & lrA + 1).Value = objFile.Name
        ws.Range("B" & lrB + 1).Value = objFile.DateLastModified
        ws.Range("C" & lrB + 1).Value = objFile.Size
    'End If
    Next
    'ws.Cells(2, 1).Delete
    'Clean up!
    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing

End Sub

Hi - unfortunately all that generated was: