I found a fantasic little macro on this site that lists all the folders, sub-folders and files along with indenting and grouping the list when transferred to the sheet but am having a little difficulty trying to modify it. (I'm a little new to VBA but am pretty intimidated by this complex-looking macro ahah) If anyone would be able to assist or point out some ideas it really would be greatly appreciated. :)
a. I'm trying to figure out what parts of the code I change or add to rather then listing the path in the cells list the folder and file name instead
b. similarly, I'm also trying to find the part where I can change to add the folder/file name to include a hyperlink containing the folder/file path. I know that you use ".Hyperlinks.Add anchor:=, Address:=FolderName & "" & FileName, TextToDisplay:=FileName" but am a little unsure which lines to use this on
c. I guess the trickiest one, to change it so it uses the select folder popup using the Application FileDialog function "msoFileDialogFilePicker" but really would have no idea how to change this without breaking the rest of the whole code.
''--found at https://stackoverflow.com/questions/56395005/excel-vba-list-files-grouped-by-folder/73669234#73669234
Public Sub ShowFilePaths()
Dim rootFolder As String
rootFolder = SelectFolder
If rootFolder = vbNullString Then Exit Sub
'--- quick fixup if needed
rootFolder = rootFolder & IIf(Right$(rootFolder, 1) = "\", vbNullString, "\")
Dim pathArray As Variant
pathArray = GetAllFiles(rootFolder)
Dim folderGroups As Object
Set folderGroups = BuildFolderDictionary(rootFolder, pathArray)
'--- when debugging, this block just clears the worksheet to make it
' easier to rerun and test the code
On Error Resume Next
With Sheet1
.UsedRange.ClearOutline
.UsedRange.Clear
.Outline.SummaryRow = xlAbove
End With
Err.Clear
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)
pathRange = pathArray
pathRange.Font.Color = RGB(237, 125, 49)
pathRange.Font.Bold = True
pathRange.Font.Italic = True
'------ now apply the indention levels to each line on the sheet
' 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
'--- 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 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"
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)
'--- the pathArray skips the first position from the fOut array
' 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")
'--- scan all paths and create a dictionary of each folder and subfolder
' 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
'--- final fixup: the root folder group should always encompass all
' 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)
'--- 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
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
