XL 2010 Copier le nom du dossier contenant le sous-dossier

Bonjour,

Je cherche à modifier la macro ci-dessous afin de faire apparaitre en colonne 1 le nom du dossier contenant le sous-dossier en face de chaque ligne.
Actuellement en colonne 2 il y a le nom du fichier
En colonne 3 le nom du sous-dossier ou est le fichier

Dim ligne
Sub arborescence()
Application.ScreenUpdating = False
racine = ("C:\....")
If racine = "" Then Exit Sub
Range("A2:E20000").ClearContents
Range("A2").Select
Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.GetFolder(racine)
ligne = 2
Lit_dossier dossier_racine, 1
End Sub
Sub Lit_dossier(ByRef dossier, ByVal niveau)
Dim xSubFolderName As String
For Each d In dossier.SubFolders
Lit_dossier d, niveau
Next
For Each f In dossier.Files
Cells(ligne, 2) = Mid(f.Name, 1, InStrRev(f.Name, ".") - 1)
Cells(ligne, 3) = dossier.Name
ligne = ligne + 1
Next
End Sub