Log In
Register
Home
Active Member
September 8, 2022
Offline
Hello all, I hope you're all well.
After finding the fantasic vba macro by Philip Treacy Create Hyperlinked List of Files in Subfolders, I was inspired to take it a little further by making some of the changes found in the comments but also to group the results by subfolders. Which then led me to find another great vba macro on StackOverflow written by PeterT at Excel VBA List Files Grouped by Folder and have been trying to incorporate both Philip Treacy's & PeterT's marcos together.
However, I've run into a little problem that I can't quite figure out how to solve.
For the hyperlinks, I'm not too sure how to get these hyperlinks when clicked, to open the file or subfolder, at the moment it only opens the "rootFolder"
Similarly, I don't really know how to display the file/subfolder name instead of the path for the hyperlink "TextToDisplay:="
If anyone has any ideas, any assistance would be greatly appreciated. I'm a little new to vba but am a fast learner (I think) haha 🙂
The code I have so far is attached as a workbook
Have also posted my question here https://stackoverflow.com/ques.....hyperlinks
See Answer
Trusted Members
Moderators
November 1, 2018
Offline
You'll need to add a loop to do the hyperlinks one at a time:
'--- copy the array to the worksheet
Const START_ROW As Long = 4
Dim pathRange As Range
Set pathRange = Sheet1.Range("A" & START_ROW).Resize(UBound(pathArray), 1)
pathRange = pathArray
Dim cell As Range
For Each cell In pathRange
cell.Worksheet.Hyperlinks.Add Anchor:=cell, Address:=cell.Value, TextToDisplay:=Mid$(cell.Value, InStrRev(cell.Value, Application.PathSeparator) + 1), ScreenTip:="Click To Open"
Next cell
pathRange.Font.Color = RGB(237, 125, 49)
pathRange.Font.Bold = True
pathRange.Font.Italic = True
Answers Post
Active Member
September 8, 2022
Offline
Wow thats fantasic, thanks! I wasnt too sure how to use a loop to fix it up but that works perfectly.
I've been playing around with the code a little bit and have been trying to change the font colours for the subfolders and files. So far I've only been able to get the
rootfolder: colour as orange, text as bold without an underline
first subfolder in rootfolder: colour as blue, text as bold without an underline
files in first subfolder in rootfolder; colour as blue, text as italic and underlined
You wouldn't know how I might be able to make all the subfolders inside the rootfolder use the colour black while having all the files blue? this is the format i would like to use
I'm guessing I have to use a loop somewhere here but am unsure how to use it....
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
pathRange.rows(theseRows).Font.Underline = True
pathRange.rows(theseRows).Font.Color = RGB(68, 114, 196)
pathRange.rows(theseRows).Font.Bold = False
pathRange.rows(theseRows).Font.Italic = True
ActiveSheet.Outline.ShowLevels RowLevels:=2, ColumnLevels:=2
End If
End With
pathRange.rows(level).Font.Bold = True
pathRange.rows(level).Font.Underline = False
pathRange.rows(level).Font.Italic = False
Next rowGroup
End Sub
Trusted Members
Moderators
November 1, 2018
Offline
Try this version:
''--found at https://stackoverflow.com/ques.....4#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 = 4
Dim pathRange As Range
Set pathRange = Sheet1.Range("A" & START_ROW).Resize(UBound(pathArray), 1)
pathRange = pathArray
Dim cell As Range
For Each cell In pathRange.Cells
cell.Worksheet.Hyperlinks.Add Anchor:=cell, Address:=cell.Value, _
TextToDisplay:=Mid$(cell.Value, InStrRev(cell.Value, Application.PathSeparator) + 1), _
ScreenTip:="Click To Open"
Next cell
With pathRange
' most items will be files, so format all cells with format for files first
With .Font
.Color = RGB(68, 114, 196)
.Bold = False
.Italic = True
End With
End With
'------ 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
ActiveSheet.Outline.ShowLevels RowLevels:=1
End If
' format the subfolders - cell above the top of the group
With .Cells(0).Font
.Color = vbBlack
.Bold = True
.Italic = False
End With
End With
Next rowGroup
' format root folder
With pathRange.Cells(1).Font
.Color = RGB(237, 125, 49)
.Bold = True
.Italic = False
End With
End Sub
Active Member
September 8, 2022
Offline
wow All working now. the wonders of vba and some people's knowledge never cease to amaze me, thank you very much for adding comments in the vba, they helped me to understand the applied macro process. Thanks again for all your assistance!
1 Guest(s)
