Extraire le chemin d'acces d'un fichier

Bonjour,

Je dispose d'un dossier contenant plusieurs sous dossiers.
Un code me permet d'extraire le nom des fichiers et de crée un lien d'accès. J'aimerais y ajouter le chemin d'accès complet.
La macro est :

Public ListeDoss() As String

Sub ChercheDoss(Chemin1 As String)
Dim Ligne As Long, Nom As String
Ligne = Range("A65536").End(xlUp).Row + 1
On Error GoTo Err1
Nom = Dir(Chemin1 & "\*" & Range("Texte").Value & "*" & Range("Ext").Value)
If Nom <> "" Then
Cells(Ligne, 1).Value = Nom
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(Ligne, 2), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
Do
Ligne = Range("A65536").End(xlUp).Row + 1
Nom = Dir
If Nom <> "" Then
Cells(Ligne, 1).Value = Nom
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(Ligne, 2), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
End If
Loop Until Nom = ""
End If
Err1:

End Sub


Sub ChercheTout()
Dim Chemin As String, i As Long
Range("A7:C65536").Clear
Chemin = Range("Doss").Value
LanceListe Chemin
For i = 1 To UBound(ListeDoss)
ChercheDoss ListeDoss(i)
Next i
End Sub


Sub ListeArborescence(Dossier As String)
Dim fs, sousdoss
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each sousdoss In fs.getfolder(Dossier).subfolders
ReDim Preserve ListeDoss(1 To UBound(ListeDoss) + 1)
ListeDoss(UBound(ListeDoss)) = sousdoss.Path
ListeArborescence sousdoss.Path
Next sousdoss
On Error GoTo 0
Set fs = Nothing
End Sub


Sub LanceListe(Dossier As String)
ReDim ListeDoss(1 To 1)
ListeDoss(1) = Dossier
ListeArborescence Dossier
End Sub


Pouvez vous m'aider ?

Merci d'avance