VBA to run a list all folder & subfolder content with column headers

[xcellrodeo]

Hi, I wonder if I could ask for some help from some very intelligent people out there.
I would like some help with creating a VBA script that returns a complete list of folders and subfolder content in a given location.
The starting point could be a text box which opens and the user has to enter a full file path which the VBA will then run from and return the results in Tab "List Details".
In the 'List Details' tab, I would like the VBA search results to be organised under the column headers in the format below:

Column A -> File Name:
Column B -> File Path:
Column C -> Folder Name (where file is located):
Column D -> Sub Folder Name (where file is located):
Column E -> File Ext (i.e jpg, xls, pdf...) :
Column F -> Date last modified:

Any help with the above would be greatly appreciated.
Thanks

 

[Zot]

This vba is to reply the OP for possible solution even if this is rather old post. This is using late binding. This presumed that you have already had a sheet called List Details.

Sub GetFileList()

Dim SelectFolder As Integer
Dim x As Long
Dim strPath As String
Dim wsList As Worksheet
Dim wb As Workbook
Dim FSO As Object
Dim FSOFolder As Object
Dim sFileName As Object

Set wsList = ActiveWorkbook.Sheets("List Details")
wsList.Range("A1") = "File Name"
wsList.Range("B1") = "File Path"
wsList.Range("C1") = "Folder Name"
wsList.Range("D1") = "subFolder Name"
wsList.Range("E1") = "File Ext"
wsList.Range("F1") = "Last Modified"

SelectFolder = Application.FileDialog(msoFileDialogFolderPicker).Show

If Not SelectFolder = 0 Then
    strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Else
    End
End If

Application.ScreenUpdating = False

Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSO.GetFolder(strPath)

LoopSubFolder FSO.GetFolder(strPath), wsList

End Sub

Sub LoopSubFolder(FSOFolder As Object, wsList As Worksheet)

Dim FName As String, FNameNoExt As String
Dim FSO As Object
Dim FSOSubFolder As Object
Dim FSOFile As Object

Set FSO = CreateObject("Scripting.FileSystemObject")

For Each FSOSubFolder In FSOFolder.Subfolders
    LoopSubFolder FSOSubFolder, wsList
Next

' Extract Detail
For Each FSOFile In FSOFolder.Files
    FName = FSOFile.Name
    FNameNoExt = Left(FName, InStr(FName, ".") - 1)
    wsList.Cells(Rows.Count, "A").End(xlUp).Offset(1) = FNameNoExt
    wsList.Cells(Rows.Count, "B").End(xlUp).Offset(1) = FSOFolder.Path
    wsList.Cells(Rows.Count, "C").End(xlUp).Offset(1) = FSO.GetParentFolderName(FSOFolder.Path)
    wsList.Cells(Rows.Count, "D").End(xlUp).Offset(1) = FSOFolder.Name
    wsList.Cells(Rows.Count, "E").End(xlUp).Offset(1) = Right(FName, Len(FName) - (Len(FNameNoExt) + 1))
    wsList.Cells(Rows.Count, "F").End(xlUp).Offset(1) = FSOFile.DateLastModified
Next

End Sub