List Folders

List Full Path (including subfolders)
copy all 3 sections into one module

Option Explicit
Dim objFSO As Object
Dim objSubFolder As Object, objSubFolders As Object
Sub ListFoldersFullPath()
Cells.Clear
Dim StartFolder As String
Dim flDlg As FileDialog
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set flDlg = Application.FileDialog(msoFileDialogFolderPicker)
flDlg.InitialFileName = Application.DefaultFilePath & "\"
If flDlg.Show = False Then Exit Sub
StartFolder = flDlg.SelectedItems(1)
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
Call Recursive_ListFoldersFullPath(StartFolder)
Set objFSO = Nothing
MsgBox "Done!"
End Sub
Sub Recursive_ListFoldersFullPath(strFolder As String)
Dim r As Long
On Error GoTo ErrorFound
Set objSubFolders = objFSO.GetFolder(strFolder).Subfolders
For Each objSubFolder In objSubFolders
r = WorksheetFunction.CountA(Range("A:A")) + 1
Cells(r, 1) = objSubFolder
DoEvents
Call Recursive_ListFoldersFullPath(objSubFolder.Path)
Next objSubFolder
Set objSubFolders = Nothing
Exit Sub
ErrorFound:
MsgBox Err.Description
On Error Resume Next
On Error GoTo 0
End Sub

Split path and folder name (including subfolders)
copy all 3 sections into one module

Option Explicit
Dim objFSO As Object
Dim objSubFolder As Object, objSubFolders As Object
Dim PosOfLastBackslash As Long
Sub ListFoldersSplitPathFolder()
Cells.Clear
Dim StartFolder As String
Dim flDlg As FileDialog
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set flDlg = Application.FileDialog(msoFileDialogFolderPicker)
flDlg.InitialFileName = Application.DefaultFilePath & "\"
If flDlg.Show = False Then Exit Sub
StartFolder = flDlg.SelectedItems(1)
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
Call Recursive_ListFoldersSplitPathFolder(StartFolder)
Set objFSO = Nothing
MsgBox "Done!"
End Sub
Sub Recursive_ListFoldersSplitPathFolder(strFolder As String)
Dim r As Long
On Error GoTo ErrorFound
Set objSubFolders = objFSO.GetFolder(strFolder).Subfolders
For Each objSubFolder In objSubFolders
PosOfLastBackslash = InStrRev(objSubFolder, "\")
r = WorksheetFunction.CountA(Range("A:A")) + 1
Cells(r, 1) = Left(objSubFolder, PosOfLastBackslash)
Cells(r, 2) = objSubFolder.Name
DoEvents
Call Recursive_ListFoldersSplitPathFolder(objSubFolder.Path)
Next objSubFolder
Set objSubFolders = Nothing
Exit Sub
ErrorFound:
MsgBox Err.Description
On Error Resume Next
On Error GoTo 0
End Sub