VBA – Search Directory and list contents with hyperlink and address

1. Copy the following code onto a module in your VBA Project (Alt+F11)

Sub HyperlinksToDirectory()
' puts hyperlinks to each of the files in a directory of your choice
' into the active sheet starting at the active cell
 Dim stDir As String
 Dim stFile As String
 Dim R As Range
 Set R = ActiveCell
 stDir = InputBox("Directory?", , Default:=CurDir())
 stFile = Dir(stDir & "\*.*")
 Do Until stFile = ""
 R.Hyperlinks.Add R, stDir & "\" & stFile, , , stFile
 Set R = R.Offset(1)
 stFile = Dir()
 Loop
 R.CurrentRegion.Sort key1:=R, order1:=xlAscending, Header:=xlNo
End Sub

2. Create a button and assign macro ‘HyperlinksToDirectory’

 

3. Before clicking the button set the active cell where you wish to place the list

4. Click the button to bring up the dialogue box

5. Type the directory address and press OK

6. A list of all the files located in the directory will be created starting on the active cell

7. Each entry is hyper linked to its respective file

 

** Additional Code

You can also display the link address next to each line

1. Add the following code onto a module in your VBA Project (Alt+F11)

Function HyperLinkText(pRange As Range) As String
Dim ST1 As String
Dim ST2 As String
Dim LPath As String
Dim ST1Local As String
 
If pRange.Hyperlinks.Count = 0 Then
 Exit Function
End If
 
LPath = ThisWorkbook.FullName
 
ST1 = pRange.Hyperlinks(1).Address
ST2 = pRange.Hyperlinks(1).SubAddress
 
If Mid(ST1, 1, 15) = "..\..\..\..\..\" Then
 ST1Local = ReturnPath(LPath, 5) & Mid(ST1, 15)
ElseIf Mid(ST1, 1, 12) = "..\..\..\..\" Then
 ST1Local = ReturnPath(LPath, 4) & Mid(ST1, 12)
ElseIf Mid(ST1, 1, 9) = "..\..\..\" Then
 ST1Local = ReturnPath(LPath, 3) & Mid(ST1, 9)
ElseIf Mid(ST1, 1, 6) = "..\..\" Then
 ST1Local = ReturnPath(LPath, 2) & Mid(ST1, 6)
ElseIf Mid(ST1, 1, 3) = "..\" Then
 ST1Local = ReturnPath(LPath, 1) & Mid(ST1, 3)
Else
 ST1Local = ST1
End If
 
If ST2 <> "" Then
 ST1Local = "[" & ST1Local & "]" & ST2
End If
 
HyperLinkText = ST1Local
End Function

Function ReturnPath(pAppPath As String, pCount As Integer) As String
Dim LPos As Integer
Dim LTotal As Integer
Dim LLength As Integer
LTotal = 0
LLength = Len(pAppPath)
Do Until LTotal = pCount + 1
 If Mid(pAppPath, LLength, 1) = "\" Then
 LTotal = LTotal + 1
 End If
 LLength = LLength - 1
Loop
ReturnPath = Mid(pAppPath, 1, LLength)
End Function

2. On the cells along the hyperlinks type the following formula [=HyperLinkText(B10)]

3. This will return the link full address for the entry in B10

4. Copy this formula down to display the remainder addresses