Sub ListFilesInFolderAndSubfolders()
    On Error GoTo ErrHandler
    
    Dim selectedFolder As FileDialog
    Set selectedFolder = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim selectedPath As String
    If selectedFolder.Show = -1 Then
        selectedPath = selectedFolder.SelectedItems(1)
        
        Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets.Add
        
        ws.Cells(1, 1).Value = "Subfolder Name"
        ws.Cells(1, 2).Value = "File Name"
        
        Dim startCell As Range
        Set startCell = ws.Cells(2, 1)
        
        ListFilesRecursive selectedPath, GetFolderName(selectedPath), startCell
        
        MsgBox "File listing completed.", vbInformation
    Else
        MsgBox "No folder selected.", vbExclamation
    End If
    
    Exit Sub
    
ErrHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical
End Sub

Sub ListFilesRecursive(ByVal folderPath As String, ByVal parentSubfolderName As String, ByRef targetCell As Range)
    Dim folder As Object, subFolder As Object
    Dim file As Object
    Dim fs As Object
    Dim subFolderPath As String
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set folder = fs.GetFolder(folderPath)
    
    For Each file In folder.Files
        targetCell.Value = parentSubfolderName
        targetCell.Offset(0, 1).Value = file.Name
        Set targetCell = targetCell.Offset(1, 0)
    Next file
    
    For Each subFolder In folder.SubFolders
        subFolderPath = subFolder.Path
        ListFilesRecursive subFolderPath, subFolder.Name, targetCell
    Next subFolder
    
    Set fs = Nothing
    Set folder = Nothing
    Set subFolder = Nothing
    Set file = Nothing
End Sub

Function GetFolderName(ByVal folderPath As String) As String
    Dim parts() As String
    parts = Split(folderPath, "\")
    GetFolderName = parts(UBound(parts))
End Function