Problème liens hypertexte automatique

J'ai trouvé une macro qui faisait à peu près ça, mais j'aimerais que ce soit fait automatiquement. Ici il demande le choix du dossier ,de l'extension...
Avez vous une idée?

'Les déclarations et la fonction getdirectory qui suivent
'permettent d'ouvrir une boite de dialogue de type "choix d'un dossier"

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
Dim Dossier As String
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Choisissez un dossier de destination pour les sauvegardes."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Dossier = GetDirectory & "\"
Else
GetDirectory = ""
End If
End Function

Sub Repertorier()
'Une méthode basique sans API pour lister les répertoires et
'sous-répertoires. Michel Pierron, MPFE 2002. Adaptation Flo Cabon sur une idée de "mrik"
'* nRow = Ligne de départ
'* FolderName = Chemin du répertoire à lister
'* Suffix = Filtre optionnel des types de fichiers
'* SubDir = True pour étendre la liste aux sous-répertoires
Dim LeMessage As String, LeRepertoire As String, Lextension As String
Dim Profondeur As VbMsgBoxResult
Dim nRow As Long

LeMessage = "Choisissez le dossier à analyser"
LeRepertoire = GetDirectory(LeMessage)
Lextension = InputBox("indiquez éventuellement une extension de fichier pour filtrer les fichiers", "Type de fichier", "*.*")
Profondeur = MsgBox("Voulez vous analyser aussi les sous-répertoires ?", vbYesNo, "Profondeur d'analyse")
nRow = InputBox("indiquez le N° de la première ligne pour le tableau de sortie", "Sortie des résultats", "1")
If Profondeur = vbYes Then
truc = Lister(nRow, LeRepertoire, Lextension, True)
Else
truc = Lister(nRow, LeRepertoire, Lextension, False)
End If
End Sub

Function Lister(nRow&, FolderName$, Optional Suffix$ = "*.*", Optional SubDir As Boolean = True)
Dim i As Long, x As Long, File As String, Folder As String, nbFolders() As String

Cells(nRow, 1) = FolderName
Cells(nRow, 1).Font.Bold = True
If Not Right(FolderName, 1) = "\" Then FolderName = FolderName & "\"
File = Dir(FolderName & Suffix)

Do While Len(File) > 0
With ActiveSheet
.Hyperlinks.Add Anchor:=.Cells(nRow, 2), _
Address:=FolderName & File, _
TextToDisplay:=File
End With
nRow = nRow + 1
File = Dir
Loop

If Not SubDir Then Exit Function
x = 0
Folder = Dir(FolderName, vbDirectory)

Do While Folder > ""
If Folder <> "." And Folder <> ".." Then
If (GetAttr(FolderName & Folder) And vbDirectory) = vbDirectory Then x = x + 1
End If
Folder = Dir
Loop

ReDim nbFolders(x + 1)
i = 1
nbFolders(i) = Dir(FolderName, vbDirectory)
Do While nbFolders(i) > ""
If nbFolders(i) <> "." And nbFolders(i) <> ".." Then
If (GetAttr(FolderName & nbFolders(i)) And vbDirectory) = vbDirectory Then i = i + 1
End If
nbFolders(i) = Dir
Loop
For i = 1 To UBound(nbFolders()) - 1
Call Lister(nRow, FolderName & nbFolders(i), Suffix)
Next
End Function