I was intrigued by this question on SO and was able to come up with a reasonably efficient answer, but I'm interested in learning about further optimizations. You can certainly look at my answer to that original question for some explanations of how I've implemented certain logic, but I'm happy to answer questions as well.

Option Explicit

Public Sub ShowFilePaths()
    Dim rootFolder As String
    rootFolder = SelectFolder

    Dim pathArray As Variant
    pathArray = GetAllFiles(rootFolder)

    Dim folderGroups As Object
    Set folderGroups = BuildFolderDictionary(pathArray)

    '--- when debugging, this block just clears the worksheet to make it
    '    easier to rerun and test the code
    On Error Resume Next
    Loop While Err.Number = 0
    On Error GoTo 0

    '--- copy the array to the worksheet
    Const START_ROW As Long = 6
    Dim pathRange As Range
    Set pathRange = Sheet1.Range("A" & START_ROW).Resize(UBound(pathArray) + 1, 1)
    pathRange.Value = pathArray

    '------ now apply the indention levels to each line on the sheet
    '       and group the same rows
    Dim rowGroup As Variant
    Dim level As Long
    For Each rowGroup In folderGroups
        Dim theseRows As String
        theseRows = folderGroups(rowGroup)
        With pathRange.rows(theseRows)
            level = Len(rowGroup) - Len(Replace(rowGroup, "\", vbNullString)) - 1
            .IndentLevel = level
            If level < 8 Then
            End If
        End With
    Next rowGroup
End Sub

Private Function SelectFolder() As String
    '--- returns the user-selected folder as a 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 ByVal onlyFolders As Boolean = False) As Variant
    '--- returns a sorted array of all filepaths in the given directory path
    Dim dirOptions As String
    If onlyFolders Then
        dirOptions = """ /a:d-h-s /b /s"
        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, _
    QuickSort fOut, LBound(fOut), UBound(fOut)

    '--- the pathArray skips the first position from the fOut array
    '    because it's always blank
    Dim pathArray As Variant
    ReDim pathArray(1 To UBound(fOut), 1 To 1)
    Dim i As Long
    For i = 1 To UBound(fOut)
        pathArray(i, 1) = fOut(i)
    Next i
    GetAllFiles = pathArray
End Function

Private Function BuildFolderDictionary(ByRef paths As Variant) As Object
    Dim folders As Object
    Set folders = CreateObject("Scripting.Dictionary")

    '--- scan all paths and create a dictionary of each folder and subfolder
    '    noting which items (rows) map into each dictionary
    Dim i As Long
    For i = LBound(paths) To UBound(paths)
        Dim folder As String
        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)
                '--- 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
    Set BuildFolderDictionary = folders
End Function

Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
    '--- from https://stackoverflow.com/a/152333/4717755
    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

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

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

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

        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
  • \$\begingroup\$ You are correct about the Quicksort and that fixed my other issue. Nice answer. \$\endgroup\$ – TinMan Jun 6 at 18:43

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.