adjusting code "Fluff" hyperlink subfolder to open

[abdelfattah]

hello
i got this code from mr.Fluff i would thank him if is possible to add to code and make it link hyperlink every subfolder to open it

Sub abdelfattah()
   Dim Fldr As String
   Dim SubFldr As Object
   Dim i As Long
 
   i = 2
   With Application.FileDialog(4)
      .AllowMultiSelect = False
      If .Show = -1 Then Fldr = .SelectedItems(1)
   End With
   With CreateObject("scripting.filesystemobject")
      For Each SubFldr In .GetFolder(Fldr).SubFolders
         Cells(i, 3) = SubFldr.Name
         i = i + 1
      Next
   End With
End Sub

thanks

 

[Misca]

Try:

Sub abdelfattah()
   Dim Fldr As String
   Dim SubFldr As Object
   Dim i As Long
 
   i = 2
   With Application.FileDialog(4)
      .AllowMultiSelect = False
      If .Show = -1 Then Fldr = .SelectedItems(1)
   End With
   With CreateObject("scripting.filesystemobject")
      For Each SubFldr In .GetFolder(Fldr).SubFolders
         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 3), _
                Address:=Fldr & Application.PathSeparator & SubFldr.Name, _
                TextToDisplay:=SubFldr.Name
         i = i + 1
      Next
   End With
End Sub

 

[abdelfattah]

astonishing ! updating many thanks for your help

 

[abdelfattah]

hi, Misca i try overcome error if i don't choose folder from browser and press cancel it gives me error in this line

      For Each SubFldr In .GetFolder(Fldr).SubFolders

i try putting this line before it but it not successful

On Error Resume Next

any idea,please?

 

[Misca]

You can solve this by adding a line that checks if the Fldr is empty:

Sub abdelfattah()
   Dim Fldr As String
   Dim SubFldr As Object
   Dim i As Long
 
   i = 2
   With Application.FileDialog(4)
      .AllowMultiSelect = False
      If .Show = -1 Then Fldr = .SelectedItems(1)
   End With
   
  [B] If Fldr <> "" Then[/B]
   
    With CreateObject("scripting.filesystemobject")
       For Each SubFldr In .GetFolder(Fldr).SubFolders
          ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 3), _
                 Address:=Fldr & Application.PathSeparator & SubFldr.Name, _
                 TextToDisplay:=SubFldr.Name
          i = i + 1
       Next
    End With
   
   [B]End If[/B]
   
End Sub

 

[abdelfattah]

well done ! Misca now it works so well thanks very much