VBA Code: Get File Name and Path

Option Explicit

Public Sub ShowFilePaths()
    Dim rootFolder As String
    rootFolder = SelectFolder
    If rootFolder = vbNullString Then Exit Sub


    rootFolder = rootFolder & IIf(Right$(rootFolder, 1) = "\", vbNullString, "\")

    Dim pathArray As Variant
    pathArray = GetAllFiles(rootFolder)

    Dim folderGroups As Object
    Set folderGroups = BuildFolderDictionary(rootFolder, pathArray)


    On Error Resume Next
    With Sheet1
        .UsedRange.ClearOutline
        .UsedRange.Clear
        .Outline.SummaryRow = xlAbove
    End With
    Err.Clear
    On Error GoTo 0


    Const START_ROW As Long = 6
    Dim pathRange As Range
    Set pathRange = Sheet1.Range("A" & START_ROW).Resize(UBound(pathArray), 1)
    pathRange = pathArray


    '       and group the same rows
    Const MAX_GROUP_LEVEL As Long = 8
    Dim rowGroup As Variant
    Dim level As Long
    Dim folderData As Variant
    Dim theseRows As String
    For Each rowGroup In folderGroups
        folderData = Split(folderGroups(rowGroup), ",")
        theseRows = folderData(0)
        level = folderData(1)
        With pathRange.rows(theseRows)
            .IndentLevel = level
            If level < MAX_GROUP_LEVEL Then
                .Group
            End If
        End With
    Next rowGroup
End Sub

Private Function SelectFolder() As String

    Dim objShell As Object
    Dim objFolder As Object
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 17)
    If Not objFolder Is Nothing Then
        SelectFolder = objFolder.self.Path
    End If
End Function

Private Function GetAllFiles(ByVal rootPath As String, _
                             Optional onlyFolders As Boolean = False) As Variant

    Dim dirOptions As String
    If onlyFolders Then
        dirOptions = """ /a:d-h-s /b /s"
    Else
        dirOptions = """ /a:-h-s /b /s"
    End If
    Dim fOut() As String
    fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & _
                                                    rootPath & _
                                                    dirOptions).StdOut.ReadAll, _
                 vbNewLine)
    QuickSort fOut, LBound(fOut), UBound(fOut)


    '    because it's always blank, but add the root folder as the first entry
    Dim pathArray As Variant
    ReDim pathArray(1 To UBound(fOut) + 1, 1 To 1)
    pathArray(1, 1) = rootPath
    Dim i As Long
    For i = 2 To UBound(fOut) + 1
        pathArray(i, 1) = fOut(i - 1)
    Next i
    GetAllFiles = pathArray
End Function

Private Function BuildFolderDictionary(ByVal root As String, _
                                       ByRef paths As Variant) As Object
    Dim folders As Object
    Set folders = CreateObject("Scripting.Dictionary")


    '    noting which items (rows) map into each dictionary
    Dim folder As Variant
    Dim i As Long
    For i = LBound(paths) To UBound(paths)
        Dim pos1 As Long
        If Not IsEmpty(paths(i, 1)) Then
            pos1 = InStrRev(paths(i, 1), "\")   'find the last folder separator
            folder = Left$(paths(i, 1), pos1)
            If Not folders.Exists(folder) Then
                '--- new (sub)folder, create a new entry
                folders.Add folder, CStr(i) & ":" & CStr(i)
            Else
                '--- extisting (sub)folder, add to the row range
                Dim rows As String
                rows = folders(folder)
                rows = Left$(rows, InStr(1, rows, ":"))
                rows = rows & CStr(i)
                folders(folder) = rows
            End If
        End If
    Next i


    '    the entries (runs from the second row to the end)...
    '    and we'll also determine the indent level using the first entry
    '    as the baseline (level 1).  stored as "rows,level" e.g. "2:7,1"
    Dim rootSlashes As Long
    rootSlashes = Len(root) - Len(Replace(root, "\", "")) - 1
    folders(root) = "2:" & UBound(paths) & ",1"

    Dim slashes As Long
    folder = folders.Keys
    For i = 1 To UBound(folder)
        slashes = Len(folder(i)) - Len(Replace(folder(i), "\", ""))
        folders(folder(i)) = folders(folder(i)) & "," & _
                                     CStr(slashes - rootSlashes)
    Next i

    For Each folder In folders
        Debug.Print folder & " - " & folders(folder)
    Next folder

    Set BuildFolderDictionary = folders
End Function

Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)

    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

    P1 = LB
    P2 = UB
    Ref = Field((P1 + P2) / 2)

    Do
        Do While (Field(P1) < Ref)
            P1 = P1 + 1
        Loop

        Do While (Field(P2) > Ref)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(Field, LB, P2)
    If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub