Loop through sub-folders and create shortcuts of each file

[sbo1985]

Hello,

I have a folder that has sub-folders. Under each sub folder, there are Excel files. Each week, the file path for folders and Excel files under these folders change.
My objective is to loop through these sub-folders and create a shortcut of each Excel file in the main folder.
Each Single time, I am trying to prompt users to select a specific main-folder as it changes from week to week.

This is a code I edited and tried to use but it is not working:

Sub CreateFileShortcut()
Dim FileSystem As Object
Dim HostFolder As String

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
 
'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings
HostFolder = myPath

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


End Sub


Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
   
    For Each File In Folder.Files
        ' Operate on each file
        sShortcutLocation = File.Name & ".lnk"
        With CreateObject("WScript.Shell").CreateShortcut(sShortcutLocation)
    .TargetPath = File.Path
    .Description = "Shortcut to the file"
     .Save
End With
       
    Next
End Sub

I would really appreciate your help,

Thank you,

 

[Micron]

As I often say, "doesn't work doesn't help".
Did you step through the code to see if it executes as expected? Looks to me that if the user chooses a folder ( .Show = True) then you are branching to NextCode, where myPath will be an empty string because the myPath = line won't execute because of the branching. So you branch to ResetSettings, which soon exits.

Branching with a bunch of GoTo's is generally considered to be poor programming.
Also, if you're going to alter settings or other critical properties, you really should have an error handler lest you end up leaving them that way. Sorry, but I didn't study the rest because of not knowing what the code does or doesn't do for you, or if you stepped through it, or if I've already id'd the issue.

Dim stuff
On Error GoTo errHandler

lotsa code

exitHere:
reset things
do other cleanup
Exit Sub

errHandler:
Msgbox "Error " & Err.Number & ": " & Err.Description
Resume exitHere (or test for particular error numbers if appropriate in an IF block)

End Sub