Problème de création de sous dossier dans un dossier

Bonjour à tous,

Je suis arrivé à créer un code VBA qui me permet d'enregistrer un document dans un dossier distinct mais je n'arrive pas à créer un sous dossier.

Le dossier principale est "commande client" et je veux créer un sous dossier par client en reprenant le nom de ce dernier. Je ne sais pas si je dois utiliser la fonction MkDit(). Dans tous les cas je transmets ci-dessous mon code, si quelqu'un peut m'aider !!

Private Sub EnregistrementBCde_Click()

'Déclaration des variables
Dim Commande As String
Dim CheminDossier As String
Dim Li As Byte

On Error GoTo 1

'Nom de dossier
CheminDossier = "C:\Users\beaud\OneDrive\Bureau\Application en cours de modif\Commande client\" '........................................Chemin pour création du dossier
Commande = Me.LbNomClient & " Commande client N° " & Me.Txtnumcde & " du " & Format(Date, "dd-mm-yyyy") & ".pdf" '...............Références de la commande à sauvegarder
If Me.LbNomClient = "" Then
Me.LbNomClient.SetFocus
Exit Sub
End If
Call test_repertoire(CheminDossier) '...................................................................vers procédure Test_repertoire (si le dossier n'existe pas il est créé)
'Enregistrement au format PDF
Application.ScreenUpdating = False '....................................................................désactivation de la mise à jour écran
Sheets("Cde client").ExportAsFixedFormat Type:=xlTypePDF, Filename:=CheminDossier & Commande, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, OpenAfterPublish:=False '................................sauvegarde du fichier au format pdf
Application.ScreenUpdating = True '.....................................................................réactivation de l'écran

Exit Sub

'Le traitement de l'erreur se p1ace en dessous d'un exit sub juste avant le end sub
1:
MsgBox "Erreur de traitement, sortie de formulaire"
Application.ScreenUpdating = True
End Sub
Sub test_repertoire(CheminDossier As String)
'
'*************************************************************************************
' fonctionne en lien avec la procédure Private Sub EnregistrementBCde_Click() *
'*************************************************************************************
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject") '................instanciation de la variable fs
If fs.FolderExists(CheminDossier) Then '.............................le repertoire existe donc rien à faire
Else: fs.CreateFolder CheminDossier '...................................le repertoire n'existe pas donc on le créait
End If
Set fs = Nothing '...................................................vide l'instanciation fs
End Sub

bonjour

essaie ceci (non-testé)

Private Sub EnregistrementBCde_Click()

      'Déclaration des variables
    Dim Commande As String
    Dim CheminDossier As String
    Dim Li As Byte

      On Error GoTo 1

      'Nom de dossier
      CheminDossier = "C:\Users\beaud\OneDrive\Bureau\Application en cours de modif\Commande client\" '<- ce répertoire doit exister
      CheminsousDossier = CheminDossier & Me.LbNomClient & "\" ' nom du sous-répertoire pour le client
       Call test_repertoire(CheminsousDossier) 'crée un sous-dossier pour le client s'il n'existe pas
      Commande = Me.LbNomClient & " Commande client N° " & Me.Txtnumcde & " du " & Format(Date, "dd-mm-yyyy") & ".pdf" '...............Références de la commande à sauvegarder
      If Me.LbNomClient = "" Then
          Me.LbNomClient.SetFocus
          Exit Sub
      End If

      'Enregistrement au format PDF
      Application.ScreenUpdating = False '....................................................................désactivation de la mise à jour écran
      Sheets("Cde client").ExportAsFixedFormat Type:=xlTypePDF, Filename:=CheminsousDossier & Commande, Quality:= _
      xlQualityStandard, IncludeDocProperties:=True, OpenAfterPublish:=False '................................sauvegarde du fichier au format pdf
      Application.ScreenUpdating = True '.....................................................................réactivation de l'écran

      Exit Sub

      'Le traitement de l'erreur se p1ace en dessous d'un exit sub juste avant le end sub
1:
        MsgBox "Erreur de traitement, sortie de formulaire"
        Application.ScreenUpdating = True
End Sub
Sub test_repertoire(CheminDossier As String)
    '
    '*************************************************************************************
    ' fonctionne en lien avec la procédure Private Sub EnregistrementBCde_Click() *
    '*************************************************************************************
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject") '................instanciation de la variable fs
    If fs.FolderExists(CheminDossier) Then '.............................le repertoire existe donc rien à faire
        Else: fs.CreateFolder CheminDossier '...................................le repertoire n'existe pas donc on le créait
    End If
    Set fs = Nothing '...................................................vide l'instanciation fs
End Sub

Je viens tester et cela bloque au niveau du "call test repertoire (CheminsousDossier) bizarre !!

re-bonjour,

essaie ceci

Private Sub EnregistrementBCde_Click()

      'Déclaration des variables
    Dim Commande As String
    Dim CheminDossier As String
    Dim CheminsousDossier As String
    Dim Li As Byte

      On Error GoTo 1

      'Nom de dossier
      CheminDossier = "C:\Users\beaud\OneDrive\Bureau\Application en cours de modif\Commande client\" '<- ce répertoire doit exister
      CheminsousDossier = CheminDossier & Me.LbNomClient & "\" ' nom du sous-répertoire pour le client
       Call test_repertoire(CheminsousDossier) 'crée un sous-dossier pour le client s'il n'existe pas
      Commande = Me.LbNomClient & " Commande client N° " & Me.Txtnumcde & " du " & Format(Date, "dd-mm-yyyy") & ".pdf" '...............Références de la commande à sauvegarder
      If Me.LbNomClient = "" Then
          Me.LbNomClient.SetFocus
          Exit Sub
      End If

      'Enregistrement au format PDF
      Application.ScreenUpdating = False '....................................................................désactivation de la mise à jour écran
      Sheets("Cde client").ExportAsFixedFormat Type:=xlTypePDF, Filename:=CheminsousDossier & Commande, Quality:= _
      xlQualityStandard, IncludeDocProperties:=True, OpenAfterPublish:=False '................................sauvegarde du fichier au format pdf
      Application.ScreenUpdating = True '.....................................................................réactivation de l'écran

      Exit Sub

      'Le traitement de l'erreur se p1ace en dessous d'un exit sub juste avant le end sub
1:
        MsgBox "Erreur de traitement, sortie de formulaire"
        Application.ScreenUpdating = True
End Sub
Sub test_repertoire(CheminDossier As String)
    '
    '*************************************************************************************
    ' fonctionne en lien avec la procédure Private Sub EnregistrementBCde_Click() *
    '*************************************************************************************
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject") '................instanciation de la variable fs
    If fs.FolderExists(CheminDossier) Then '.............................le repertoire existe donc rien à faire
        Else: fs.CreateFolder CheminDossier '...................................le repertoire n'existe pas donc on le créait
    End If
    Set fs = Nothing '...................................................vide l'instanciation fs
End Sub

le sous dossier se créé bien mais le document reste dans le dossier de base

C'est bon je viens de trouver mon erreur. Je n'ai pas changer le chemin au niveau de l'enregistrement au format PDF.

Merci pour ton aide précieuse