List folders and files

[mmn1000]

Hi,
I want to list all folders and subfolders with their files in Excel using macros.

For this, I used the following code, which only lists the names of the folders

Sub FolderNames()
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, 3).Value = Array("Path", "Dir", "Name")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.getFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 3).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 3).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, 3).Value = Array(SubFolder.Path, Left(SubFolder.Path, InStrRev(SubFolder.Path, "\")), SubFolder.Name)
Next SubFolder
For Each subfld In prntfld.SubFolders
    getSubFolder subfld
Next subfld
End Sub

 

[Fuji]

See if this is kind of what you are after.

Sub test()
    Dim myDir As String, temp(), myList, myExtension As String
    Dim SearchSubFolders As Boolean, Rtn As Integer, msg As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1)
    End With
    If myDir = "" Then Exit Sub
    msg = "Enter File name and Extension" & vbLf & "following wild" & _
    " cards can be used" & vbLf & "* # ?"
    myExtension = Application.InputBox(msg)
    If (myExtension = "False") + (myExtension = "") Then Exit Sub
    Rtn = MsgBox("Include Sub Folders ?", vbYesNo)
    SearchSubFolders = Rtn = 6
    myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders)
    If Not IsError(myList) Then
        Sheets(1).Cells(1).Resize(UBound(myList, 2), 2).Value = _
        Application.Transpose(myList)
    Else
        MsgBox "No file found"
    End If
End Sub
 
Private Function SearchFiles(myDir As String _
    , myFileName As String, n As Long, myList() _
    , Optional SearchSub As Boolean = False) As Variant
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.getfolder(myDir).Files
        Select Case myFile.Attributes
        Case 2, 4, 6, 34
        Case Else
            If (Not myFile.Name Like "~$*") _
                * (UCase(myFile.Name) Like UCase("*" & myFileName)) Then
                n = n + 1
                ReDim Preserve myList(1 To 2, 1 To n)
                myList(1, n) = myDir
                myList(2, n) = myFile.Name
            End If
        End Select
    Next
    If SearchSub Then
        For Each myFolder In fso.getfolder(myDir).subfolders
            SearchFiles = SearchFiles(myFolder.Path, myFileName, _
            n, myList, SearchSub)
        Next
    End If
    SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function