XL 2019 Deuxième Répertoire.

[BALANCIE]

Bonjour,

J'ai récupéré un code qui m'intéresse et j'aimerais rajouter un deuxième répertoire pour son utilisation.
Mais mes connaissances en VBA sont vraiment limités.
Pouvez-vous m'aider.
Il s'agit pour moi d'effectuer la même opération de : C:\Rapport\Equipe1
en créant le Répertoire D:\Rapport\Equipe2

Merci à vous tous.
BALANCIE

 

[Lolote83]

Bonjour @BALANCIE ,
Le code ici donne la cellule C6 comme répertoire

Avec le code suivant, on affectera à deux boutons les macros
- Bouton1 = affectation de la macro Sub Chemin1
- Bouton2 = affectation de la macro Sub Chemin2

Sub Chemin1()
    Call Creation_Repertoires_2(Range("C6"))
End Sub

Sub Chemin2()
    Call Creation_Repertoires_2(Range("C7"))
End Sub

Public Sub Creation_Repertoires_2(xChemin)
    Dim FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'Chemin = Trim(Range("C6"))
    Chemin = Trim(xChemin)
    If Rep_Existe(Chemin) = False Then
       MsgBox "Le chemin " & Chemin1 & " est absent."
       Exit Sub
    End If
    NouvRepertoire = Trim(Range("D4"))
    If Rep_Existe(Chemin & "\" & NouvRepertoire) = False Then
        MkDir Chemin & "\" & NouvRepertoire
    End If
    ChemSousRep = Chemin & "\" & NouvRepertoire
    For Lig = 11 To 25
        SousRep = Trim(Range("C" & Lig))
        If Rep_Existe(ChemSousRep & "\" & SousRep) = False Then
            MkDir ChemSousRep & "\" & SousRep
        End If
    Next
    Set FSO = Nothing
    MsgBox " Dossiers & Sous-Dossiers réussis.", vbInformation
End Sub

@+ Lolote83

 

[fanch55]

Bonjour,
Une autre solution possible ( salut @Lolote83 )

Sub Creation_Repertoires()
Dim Lr      As Long
Dim Cel     As Range
   ' dernière cellule non vide de la colonne C
    Lr = Cells(Rows.Count, "C").End(xlUp).Row
   ' pour chaque cellule dans la colonne C à partir de la ligne 11 ( jusqu'à la ligne Lr )
    For Each Cel In Range("C11:C" & Lr)
       ' on indique les arborescences à créer
        Create_Rep [C6] & "\" & [D4] & "\" & Cel
        Create_Rep [C7] & "\" & [D4] & "\" & Cel
    Next
    MsgBox "Fini"
End Sub
Sub Create_Rep(Arbo As String)
Dim FSO As Object
Dim Chemin As String
Dim Folders, Folder
Set FSO = CreateObject("Scripting.FileSystemObject")
   ' On décompose l'arborescence en un tableau de sous-dossiers
    Folders = Split(Arbo, "\")
   ' Pour chaque sous-dossier dans la table
    For Each Folder In Folders
       ' on reconstruit au fur et à mesure l'arborescence des sous-dossiers à créer
        Chemin = IIf(Chemin = "", "", Chemin & "\" ) & Trim(Folder)
       ' s'il n'existe pas, on le crée
        If Not FSO.FolderExists(Chemin) Then FSO.CreateFolder (Chemin)
    Next
Set FSO = Nothing
End Sub

 

[BALANCIE]

Bonjour @+ Lolote83
Merci pour le retour.
J'ai essayé, cela ne marche pas , il m'indique à la ligne :

Public Sub Creation_Repertoires_2(xChemin)
Chemin = Trim(xChemin)
If Rep_Existe(Chemin) = False Then

"Chemin ambigu Rep_Existe"

Sinon l'idée de la solution est bonne.
BALANCIE

 

[Lolote83]

Re bonjour @BALANCIE, @fanch55,
Je ne comprends pas pourquoi.
Je n'ai rien changé dans le code d'origine.
J'ai simplement copié la partie du code qui sert à la création, que j'ai renommé en Sub Creation_Repertoires_2(xChemin) et j'ai fait 2 autres petites macro qui y font appel en passant en paramètre soit le contenu de la cellule C6, soit celui de la C7

Par contre, dans le fichier d'origine, je me suis aperçu lorsque le répertoire n'existe pas le message est erroné.
Remplacer Chemin1 par chemin. Cela donnerra maintenant la valeur du chemin

If Rep_Existe(Chemin) = False Then
       MsgBox "Le chemin " & Chemin1 & " est absent."
       Exit Sub
End If

OUPS, je viens de voir qu'il y avait aussi des sous-dossiers à creer. Voir du coup le code de @fanch55 qui en tient compte.

@+ Lolote83

 

[BALANCIE]

Re-Bonjour @Lolote83

Je n'avais pas vu la deuxième solution.
C'est parfait, exactement ce que je recherchais.
Grand Merci .
C'est Résolu.
BALANCIE.

Une autre solution possible ( salut

 

[Lolote83]

Re bonjour,
Ce n'est pas à moi que revient le mérite mais à @fanch55
C'est donc plutôt son post#3 qu'il aurait fallu passer en résolu.
@+ Lolote83