XL 2019 Copier dossier avec sous dossier

[Olympe46]

Bonjour à tous,

Voici mon code qui me permet de créer mon dossier lorsque que je saisi un nouveau agent en cliquant sur mon bouton ajouter un agent qui ouvre une fenêtre ou je dois saisir le nom et prénom [IMG alt="Nom : Capture.PNG
Affichages : 1
Taille : 14,5 Ko"]https://www.developpez.net/forums/a...ichier-sous-fichier-bouton/capture.png/[/IMG] et [IMG alt="Nom : Capture2.PNG
Affichages : 1
Taille : 10,2 Ko"]https://www.developpez.net/forums/a...chier-sous-fichier-bouton/capture2.png/[/IMG]

cela créer une nouvelle feuille (qui copie la feuille modèle) et la renomme du nom prénom et un dossier

Maintenant j'aimerais que quand le dossier se créer il copie un dossier type qui contient des sous dossiers

Si c'est possible

Sub dupliquer()
Dim numFacture As String, sDossier As String
numFacture = InputBox("NOTER NON PRENON DU NOUVEAU AGENT")
Sheets("AGENTTYPE").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = numFacture
'Chemin du dossier (Dans le même dossier que le classeur ouvert)
sDossier = ThisWorkbook.Path & "\" & numFacture
'Si le dossier n'existe pas
If Dir(sDossier, vbDirectory) = "" Then
'Création du dossier
MkDir sDossier
'Fin de la condition
End If
End Sub


Merci à tous pour votre futur aide

 

[fanch55]

Bonjour,

Sub dupliquer()
Dim NumFacture As String, sDossier As String, Source As String
Dim Fso As Object
    NumFacture = InputBox("NOTER NOM PRENOM DU NOUVEAU AGENT")
    If NumFacture <> vbNullString Then
        Worksheets("AGENTTYPE").Copy after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = NumFacture
        'Chemin du dossier (Dans le même dossier que le classeur ouvert)
        sDossier = ThisWorkbook.Path & "\" & NumFacture
        'Chemin du dossier source
        Source = "D:\Users\?????\Documents\Club\Xl Downloads\Linda" ' à préciser
        Set Fso = CreateObject("Scripting.FileSystemObject")
            If Not Fso.FolderExists(sDossier) Then Fso.CreateFolder sDossier
            Fso.CopyFolder Source, sDossier, True
        Set Fso = Nothing
    End If
End Sub

 

[Olympe46]

Bonjour,

Merci beaucoup tu me sauve la vie