VBA to provide links to Folders, sub folders and files

[davidalldred]

Hi There I have a VBA code that returns links to folders, sub folders and files. It currently works but only by inserting the file path into the VBA code. What I want to do is to change this to look up a cell within a sheet which has the file path in it and making it easier for the user to change the file path. I have tried so many options but with no luck, can anyone try to fix my code please?

This is the code that I can't change:

List_Folders_and_Files "C:\Users\david\OneDrive\Documents", .Range("A2")

This is the macro code that works.

Option Explicit

Public Sub Main_List_Folders_and_Files()

Dim FolderLocation As Range
Dim strLocation As String

'This line updates from the input sheet
Set FolderLocation = Worksheets("SheetX").Range("C11")
'Set the current directory to the the folder path.
ChDrive FolderLocation
ChDir FolderLocation

Worksheets("Folder Links").Activate


With ActiveSheet
.Cells.Clear

List_Folders_and_Files "C:\Users\david\OneDrive\Documents", .Range("A2")


End With

End Sub


Private Function List_Folders_and_Files(folderPath As String, destCell As Range) As Long

Dim FSO As Object
Dim FSfolder As Object, FSsubfolder As Object, FSfile As Object
Dim folders As Collection, levels As Collection
Dim subfoldersColl As Collection
Dim n As Long, c As Long, i As Long

Set FSO = CreateObject("Scripting.FileSystemObject")
Set folders = New Collection
Set levels = New Collection

'Add start folder to stack

folders.Add FSO.GetFolder(folderPath)
levels.Add 0

n = 0

Do While folders.Count > 0

'Remove next folder from top of stack

Set FSfolder = folders(folders.Count): folders.Remove folders.Count
c = levels(levels.Count): levels.Remove levels.Count

'Output this folder and its files

'destCell.Offset(n, c).Value = "'" & FSfolder.Name 'OLD
destCell.Worksheet.Hyperlinks.Add Anchor:=destCell.Offset(n, c), Address:=FSfolder.Path, TextToDisplay:=FSfolder.Name
n = n + 1
c = c + 1
For Each FSfile In FSfolder.Files
'destCell.Offset(n, c).Value = "'" & FSfile.Name 'OLD
destCell.Worksheet.Hyperlinks.Add Anchor:=destCell.Offset(n, c), Address:=FSfile.Path, TextToDisplay:=FSfile.Name
n = n + 1
Next

'Get collection of subfolders in this folder

Set subfoldersColl = New Collection
For Each FSsubfolder In FSfolder.SubFolders
subfoldersColl.Add FSsubfolder
Next

'Loop through collection in reverse order and put each subfolder on top of stack. As a result, the subfolders are processed and
'output in the correct ascending ASCII order

For i = subfoldersColl.Count To 1 Step -1
If folders.Count = 0 Then
folders.Add subfoldersColl(i)
levels.Add c
Else
folders.Add subfoldersColl(i), , , folders.Count
levels.Add c, , , levels.Count
End If
Next
Set subfoldersColl = Nothing

Loop

List_Folders_and_Files = n

End Function




Thanks in advance. Dave

 

[AC PORTA VIA]

try this.

Public Sub Main_List_Folders_and_Files()

Dim FolderLocation As Range
Dim strLocation As String

'This line updates from the input sheet
Set FolderLocation = Worksheets("Sheet1").Range("C11")
ChDir FolderLocation

Worksheets("sheet2").Activate


With Worksheets("sheet2")
.Cells.Clear

List_Folders_and_Files Worksheets("Sheet1").Range("C11").Value, Worksheets("sheet2").Range("A2")


End With

End Sub

 

[davidalldred]

try this.

Public Sub Main_List_Folders_and_Files()

Dim FolderLocation As Range
Dim strLocation As String

'This line updates from the input sheet
Set FolderLocation = Worksheets("Sheet1").Range("C11")
ChDir FolderLocation

Worksheets("sheet2").Activate


With Worksheets("sheet2")
.Cells.Clear

List_Folders_and_Files Worksheets("Sheet1").Range("C11").Value, Worksheets("sheet2").Range("A2")


End With

End Sub

Thanks ever so much @AC PORTA VIA , works like a dream! I wish I posted this much much sooner, but wanted to try and learn how to modify it myself. I will look at the differences between the two codings and work it out, as it doesn't seem you made big changes, just important ones. Thanks again. Dave.