List Files Sorted Alphabetically and Grouped by Folder

[BadDogTitan]

The following macro groups files by folder and produces the desired output. However, it is very slow when it runs on a large directory, like 'My Pictures' with 30,000+ files.

I suspect I don't need a double loop, or perhaps I can use an array, but I am fairly new to VBA, and not sure how to implement.

Can anyone help?

Thanks.

[FONT=Verdana]Option Explicit[/FONT]
[FONT=Verdana]Sub cmdList()
    Dim objShell    As Object
    Dim objFolder   As Object
    Dim sPath       As String
    Dim fOut        As Variant
    Dim r           As Integer
    Dim listRng     As Range
    Dim cell        As Range
    Dim i           As Integer
    Dim j           As Integer[/FONT]
[FONT=Verdana]    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Select Folder", 0, 17)
    If objFolder Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    sPath = objFolder.self.Path
    Set objFolder = Nothing: Set objShell = Nothing
    
    r = 6: Range(r & ":" & Rows.Count).Delete
    Cells(r - 1, 1) = sPath[/FONT]
[FONT=Verdana]    fOut = Split(CreateObject("WScript.Shell").exec("cmd /c dir """ & sPath & """ /a:-h-s /b /s").StdOut.ReadAll, vbNewLine)[/FONT]
[FONT=Verdana]    Cells(r, 1).Resize(UBound(fOut), 1) = WorksheetFunction.Transpose(fOut)
    
    Set listRng = Cells(r, 1).CurrentRegion
    listRng.Sort Key1:=Cells(r, 1), Order1:=xlAscending, Header:=xlYes
    
    For i = 1 To listRng.Count
        For j = i + 1 To listRng.Count
            If InStr(listRng.Cells(j), listRng.Cells(i)) Then
                With listRng.Cells(j)
                    .Rows.Group
                    .IndentLevel = .Rows.OutlineLevel - 1
                End With
            Else
                Exit For
            End If
        Next j
    Next i
    ActiveSheet.Outline.SummaryRow = xlAbove
    Application.ScreenUpdating = True
End Sub[/FONT]