Creer dossier

Bonjour

je cherche a modifier le code ci-joint afin de créer le dossier dans le fichier source au lieu de le créer a la base du lecteur.
Sub CreerDossier()

Dim Fe As Worksheet
Dim Tbl(1 To 5) As String
Dim DosAnnée As String
Dim DosClient As String
Dim DosMachine As String
Dim DosIntervention As String
Dim I As Integer

Set Fe = Worksheets("PARAMETRE")

With Fe
Dossier = .Range("L4")
DosAnnée = .Range("L2")
DosClient = .Range("E4")
DosMachine = .Range("E27") & "_" & .Range("E29")
DosIntervention = .Range("E53") & "_" & .Range("E32") & "_" & .Range("F32") & "_" & .Range("G32")

End With

'stocke dans un tableau pour boucler ensuite
Tbl(1) = Dossier
Tbl(2) = Dossier & "\" & DosAnnée
Tbl(3) = Dossier & "\" & DosAnnée & "\" & DosClient
Tbl(4) = Dossier & "\" & DosAnnée & "\" & DosClient & "\" & DosMachine
Tbl(5) = Dossier & "\" & DosAnnée & "\" & DosClient & "\" & DosMachine & "\" & DosIntervention

'le lecteur par défaut est celui où est enregistré le classeur
ChDir Split(ThisWorkbook.Path, "\")(0) & "\"

For I = 1 To 5

'gère les éventuelles erreurs
On Error Resume Next

'vérifie si le dossier existe déjà
If Dir(Tbl(I), vbDirectory) = "" Then

'crée le dossier dans le lecteur
MkDir Tbl(I)

'si une erreur est générée, message et fin de procédure...
If Err.Number <> 0 Then

MsgBox "Erreur lors de la création du dossier '" & Split(Tbl(I), "\")(I - 1) & "' !"
Exit Sub

End If

End If

Next I

'enregistre une copie dans le sous-dossier avec le nom du client
ThisWorkbook.SaveCopyAs Dossier & "\" & DosAnnée & "\" & DosClient & "\" & DosMachine & "\" & DosIntervention & "\" & DosClient & "_" & DosIntervention & ".xlsm"

End Sub

je vous joint le fichier pour exemple.

merci de votre aide

François