VBA Hyperlink file within a folder with File Section OPTION?

[FGaxha]

Hi, need help?
I have a vba code to hyperlink all file in a folder.
Im looking for vba to to give me the option to select folder location as below.

My Hyperlink VBA is:
Sub InsertFilesInFolder()
Dim sPath As String, Value As String
Dim WS As Worksheet
Set WS = Sheets.Add
sPath = ActiveWorkbook.Path & "\"
'Value = Dir(sPath, &H1F)'exctract all kind of files, pdf,text,word
Value = Dir(sPath & "*.xls*", &H1F) 'exctract only excel file
WS.Range("A1") = "Filename"
Set StartCell = WS.Range("A2")
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(sPath & Value) = 16 Then
Else
If Value <> ActiveWorkbook.Name And Value <> "~$" & ActiveWorkbook.Name Then
StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _
Value, TextToDisplay:=Value
Set StartCell = StartCell.Offset(1, 0)
End If
End If
End If
Value = Dir
Loop
End Sub

 

[AC PORTA VIA]

try this.

Sub InsertFilesInFolder()
Dim sPath As String, value As String
Dim WS As Worksheet
Set WS = Sheets.Add
    With Application.FileDialog(msoFileDialogFolderPicker)
       .Show
        If .SelectedItems.Count > 0 Then
            sPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
value = Dir(sPath & "*.xls*", &H1F) 'exctract only excel file
WS.Range("A1") = "Filename"
Set StartCell = WS.Range("A2")
Do Until value = ""
If value = "." Or value = ".." Then
Else
If GetAttr(sPath & value) = 16 Then
Else
If value <> ActiveWorkbook.Name And value <> "~$" & ActiveWorkbook.Name Then
StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _
sPath & value, TextToDisplay:=value
Set StartCell = StartCell.Offset(1, 0)
End If
End If
End If
value = Dir
Loop
End Sub

 

[FGaxha]

try this.

Sub InsertFilesInFolder()
Dim sPath As String, value As String
Dim WS As Worksheet
Set WS = Sheets.Add
    With Application.FileDialog(msoFileDialogFolderPicker)
       .Show
        If .SelectedItems.Count > 0 Then
            sPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
value = Dir(sPath & "*.xls*", &H1F) 'exctract only excel file
WS.Range("A1") = "Filename"
Set StartCell = WS.Range("A2")
Do Until value = ""
If value = "." Or value = ".." Then
Else
If GetAttr(sPath & value) = 16 Then
Else
If value <> ActiveWorkbook.Name And value <> "~$" & ActiveWorkbook.Name Then
StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _
sPath & value, TextToDisplay:=value
Set StartCell = StartCell.Offset(1, 0)
End If
End If
End If
value = Dir
Loop
End Sub

Thank you so much for your help.
This is great.

 

[AC PORTA VIA]

Thank you so much for your help.
This is great.

You are welcome- glad to help!