Remplir un fichier générique pour créer x répertoire/fichiers spécifiques

bonjour à tous,

j'utilise le forum et les aides pour essayer développer en VBA. j'ai déjà écris plusieurs code mais là je suis bloqué.

Contexte :

j'utilise au quotidien un fichier générique pour créer des dossiers de fabrication. Je complète manuellement ces dossiers de fabrication avec des données variables spécifiques du lot à fabriquer et chaque lot est composé de x sous-lot.

par exemple le lot 223 comprends 5 sous lots : je vais devoir remplir 5 fois le dossier générique avec les données spécifiques du lot (le numéro du lot : ie 223, le numéro du sous lot :1, la date de fabrication, etc..). donc j’obtiens un fichier excel 223-1 complété des infos précédentes que j'enregistre dans le dossier 223-1.Puis ainsi de suite pour le sous lot 2 : 223-2, le sous lot 3: 223-3, etc....

Besoin:

j'aimerai sur un premier onglet (nommé "inj" dans mon fichier) de mon dossier de lot générique (ou grâce à userform option future) définir les éléments variables qui vont être injecté dans l'onglet suivant (nommé feuil1 dans mon fichier) qui contient mon dossier de lot actuel.

Je veux définir le lot(XXX) , le nombre de sous lot maximum que je veux créer (par exemple 10), entrer cette donnée dans la case nombre de sous lot à créer.

ensuite exécuter le code , cela va créer un dossier "lot XXX", un sous dossier nommé "XXX-numéro du sous lot" pour chaque sous lot donc (10 dans l’exemple ) dans le dossier lot XXX et pour finir enregistrer une copie de l'excel compléter de toutes les infos idéalement sans accès au premier onglet ou userform.

j'ai essayé de faire cela dans le fichier excel joint mais cela ne marche pas tout le temps ou le code plante.

j'ai créé une boucle mais je ne dois pas faire les choses correctement.

si vous pouvez m'aider pour réaliser ça cela me simplifiera vraiment la vis au quotidien.

merci

Damien

bonjour à tous

si le sujet n'est pas assez clair je peux compléter n'hésitez pas

merci bcp

Damien

Bonjour Damien, bonjour le forum,

Si j'ai bien compris, ton fichier en pièce jointe avec le code ci-dessous :

Option Explicit

Sub Macro1()
Dim OI As Worksheet
Dim OM As Worksheet
Dim L As Integer
Dim SL As Integer
Dim DC As Date
Dim T As String
Dim OP As Integer
Dim LR As Integer
Dim DFR As Date
Dim I As Integer
Dim OD As Worksheet

Set OI = Worksheets("inj")
Set OM = Worksheets("Modèle")
L = OI.Range("B4").Value
SL = OI.Range("C4").Value
DC = DateSerial(Year(OI.Range("D4")), Month(OI.Range("D4")), Day(OI.Range("D4")))
T = OI.Range("E4").Value
OP = OI.Range("F4").Value
LR = OI.Range("G4").Value
DFR = DateSerial(Year(OI.Range("H4")), Month(OI.Range("H4")), Day(OI.Range("H4")))
OM.Copy after:=Sheets(Sheets.Count)
Set OD = ActiveSheet
OD.Name = L
OD.Range("B4") = L
OD.Range("D4") = OP
OD.Range("B12").Value = DC
OD.Range("C12").Value = T
OD.Range("B14").Value = LR
OD.Range("C14").Value = DFR
For I = 1 To SL
    OM.Copy after:=Sheets(Sheets.Count)
    Set OD = ActiveSheet
    OD.Name = L & "-" & I
    OD.Range("B4") = L
    OD.Range("C4") = I
    OD.Range("D4") = OP
    OD.Range("B12").Value = DC
    OD.Range("C12").Value = T
    OD.Range("B14").Value = LR
    OD.Range("C14").Value = DFR
Next I
End Sub

Bonjour et bienvenue sur le forum

Bonjour à tous

Une variante .

Bye !

merci bcp à tous les 2 pour vos réponses

c'est bien ce que je voulais, je vais potasser les codes pour bien comprendre

merci encore, j'adore ce forum, l'entraide est de mise c'est chouette

Damien

bonjour à tous

et merci encore GMB et Thauthème (bon jeu de mot sétois), j'ai pris le temps de regarder le code.

gmb, ta proposition se rapproche le plus de ce que je voulais faire mais j'arrive pas à faire une dernière étape

exemple : lot 223 et sous lot de 1 à 5

avec ton code, gmb, on crée bien 5 dossiers intitulés 223-1, 223-2, ...223-5 contenant chacun un fichier.xlsx bien intitulé et complété des valeurs.

1) mais j'aimerai aussi créer un dossier racine 223 qui contient tous les dossiers précédemment cités.

j'ai essayer avec la commande mkdir mais il écrit 223 devant chaque dossier "223223-1" et il crée un dossier vierge 223!!

2)à terme ces dossiers seront à créer sur un serveur avec une adresse du type \\monserveur\dossier de lot \ "ici j'aurai mes dossiers avec n° de lot (223;224, etc..)"\dossier avec sous lot (223-1)

est ce possible d'utiliser ce type d'adresse avec MKdir?

3) pour finir, j'aimerai protéger le fait que si les fichiers et dossiers existe déjà on ne puisse pas effacer les dossiers et fichiers existants

j'ai regarder pour faire un test avant d'aller plus loin mais cela plante la macro, l’idée serait de faire un message qui indique à l'utilisateur que cela n'est pas possible et que cela arrêt la macro proprement et que l'on puisse saisir un autre numéro.

si quelqu'un à un peu de temps pour m'aider, cela serait cool merci

Bonjour

Bonjour à tous

Une nouvelle version qui traite ton cas 1)

Pour les autres cas, je pense que ThauThème qui est beaucoup plus calé que moi sera plus à même de te répondre. A tout seigneur tout honneur, : je lui passe respectueusement la main.

Bye !

Bonjour à tous,

J'ai un code à vous proposer, mais que je n'ai pas testé en intégralité. J'ai suivi le post de loin donc je n'ai pas suivi le besoin avec précision et il faudra probablement adapter certaines choses (notamment la façon de déterminer les chemins complets suivant les cas) sur lesquelles je ne me suis pas focalisé. Il y a 2 pré-requis :

- ajouter la référence (Références/outils) Microsoft Scripting Runtime,
- appeler les chemins complets des fichiers, et pour cet exemple précis, il faut le faire depuis la feuille (ici, j'ai pris en exemple A1:A5) mais il est tout à fait possible de le faire via VBA.

Voici le code :

Sub Principale() 'MACRO EXECUTANTE (POUR EXEMPLE)

For n = 1 To 5 'de 1 à 5 (à adapter)
    Call CreerDossiersFichier(Range("A" & n).Value) 'appeler macro Creer... parcourant les cellules en A (où se trouvent les chemins) <<< ADAPTER
Next

End Sub

Sub CreerDossiersFichier(Chemin$) 'MACRO PARAMETREE

Dim fso As FileSystemObject
Dim Lecteur$, souschemin$
Dim i%
Dim Dossier

Set fso = New FileSystemObject 'instanciation du nouveau file system object
Dossier = Split(Chemin, "\") 'divise le chemin, va du lecteur (item 0) au fichier (item ubound)
Lecteur = Dossier(0) 'affectation lecteur à tester

If Not fso.DriveExists(Lecteur) Then 'si lecteur n'existe pas
    MsgBox "Le lecteur " & Lecteur & " est introuvable !!!", vbCritical, "Erreur - disque inexistant"
    Exit Sub 'sortie procédure
End If

i = 1 'initialisation i (dossier racine)
souschemin = Lecteur 'initialisation souschemin, répertoire racine
While i <= UBound(Dossier) - 1 'tant que i inf ou égal au nombre de dossiers (item ubound correspondant au fichier)
    souschemin = souschemin & "\" & Dossier(i) 'souschemin concatène le dossier enfant
    If Not fso.FolderExists(souschemin) Then 'si ce répertoire n'existe pas
        MkDir (souschemin) 'création du répertoire
    End If
    i = i + 1 'incrémentation i
Wend

If Not fso.FileExists(Chemin) Then 'si le fichier n'existe pas
    Mafeuilleacopier.Copy 'copie feuille (à adapter)
    ActiveWorkbook.Close savechanges:=True, Filename:=Chemin 'fermeture et sauvegarde au nom chemin complet (<=> création fichier)
End If

End Sub

Cdlt,

Salut gmb

la macro plante à l’exécution au niveau du save copy

aurais tu une idée?

merci

Damien

Bonjour à tous

Nouvelle version.

Bye !

Bonjour à tous,

Damien, je ne sais pas si c'est à moi que tu adressais ton commentaire mais j'ai édité le code (il manquait un s à savechanges). Si tu utilises mon code, il faut un minimum l'adapter au tien (ex : Mafeuilleàcopier est à remplacer par exemple).

Cdlt,

merci à tous les 2 pour votre réactivité.

GMB la nouvelle version ne plante plus mais en fait je n'ai pas été assez clair je pense mais ce que tu me proposais au début convenais mais j'avais besoin d'un niveau de plus dans l'arborescence :

je m'explique :

ta première version faisait c:\lots\223-1\223-1.xls
c:\lots\223-2\223-2.xls

la dernière version fait : c:\lots\223\223-1.xls

\223-2.xls (dans le même répertoire que le précédent)

en fait ce que je veux c'est : c:\lots\223\223-1\223-1.xls

c:\lots\223\223-2\223-2.xls

un sous dossier spécifique donc en dessous d'un dossier racine commun

si plus clair merci encore

damien

J'ai adapté le code de gmb pour y intégrer mon code pour la partie création (car il permet de créer le chemin complet si besoin). Il faut juste ajouter la référence Microsoft ScriptingRuntime (via Référence/Outils). Je suis sur mac donc je n'ai pas testé mais j'imagine que ça devrait marcher :

Option Explicit

Sub CréerLesSousDossiers()

    Dim Chemin As String, NomHotel As String, Fichier As String, CheminComplet$
    Dim wS As Worksheet, fi As Worksheet, f1 As Worksheet
    Dim i&, y&, nb&, v, nomlot$, nom$
    Dim z As Byte

    Application.ScreenUpdating = False
    Set fi = Sheets("inj")
    Set f1 = Sheets("Feuil1")

    For i = 4 To fi.Range("B" & Rows.Count).End(xlUp).Row
        nb = fi.Range("C" & i).Value

        For y = 1 To nb '+ 1
            fi.Range("B" & i).Copy f1.Range("B4")
            f1.Range("C4") = fi.Range("B" & i) & "-" & y
            fi.Range("F" & i).Copy f1.Range("D4")
            f1.Range("B12") = fi.Range("D" & i)
            f1.Range("C12") = fi.Range("E" & i)
            f1.Range("B14") = fi.Range("G" & i)
            f1.Range("C14") = fi.Range("H" & i)

            nomlot = f1.Range("C4") '& "-" '& .Cells(y, 1).Value 'nom du lot
            nom = Range("B" & i) & "\" & nomlot 'partie répertoire dossier et sous-dossier
            Chemin = "c:\lots\" & nom 'chemin répertoire
            Fichier = nomlot & " " & Format(Date, "dd.mm.yyyy") & ".xlsx" 'nom fichier
            CheminComplet = Chemin & "\" & Fichier 'nom complet du fichier
            Call CreerDossiersFichier(CheminComplet, f1)
        Next y
    Next i
    f1.Range("B4:D4,B12:D12,B14:d14").ClearContents
    MsgBox "Travail terminé."
End Sub

Sub CreerDossiersFichier(Chemin$, Feuille as worksheet) 'MACRO PARAMETREE

Dim fso As FileSystemObject
Dim Lecteur$, souschemin$
Dim i%
Dim Dossier

Set fso = New FileSystemObject 'instanciation du nouveau file system object
Dossier = Split(Chemin, "\") 'divise le chemin, va du lecteur (item 0) au fichier (item ubound)
Lecteur = Dossier(0) 'affectation lecteur à tester

If Not fso.DriveExists(Lecteur) Then 'si lecteur n'existe pas
    MsgBox "Le lecteur " & Lecteur & " est introuvable !!!", vbCritical, "Erreur - disque inexistant"
    Exit Sub 'sortie procédure
End If

i = 1 'initialisation i (dossier racine)
souschemin = Lecteur 'initialisation souschemin, répertoire racine
While i <= UBound(Dossier) - 1 'tant que i inf ou égal au nombre de dossiers (item ubound correspondant au fichier)
    souschemin = souschemin & "\" & Dossier(i) 'souschemin concatène le dossier enfant
    If Not fso.FolderExists(souschemin) Then 'si ce répertoire n'existe pas
        MkDir (souschemin) 'création du répertoire
    End If
    i = i + 1 'incrémentation i
Wend

If Not fso.FileExists(Chemin) Then 'si le fichier n'existe pas
    Feuille.Copy 'copie feuille en argument
    ActiveWorkbook.Close savechanges:=True, Filename:=Chemin 'fermeture et sauvegarde au nom chemin complet (<=> création fichier)
End If

End Sub

Cdlt,

Nickel !

Oui, une fois la référence ajoutée dans le fichier, plus besoin d'y toucher...

MkDir crée en fait un dossier au sein d'un répertoire déjà existant mais ça ne marche pas si le répertoire parent, le contenant, n'existe pas. La boucle permet, quand ils n'existent pas, de créer tous les répertoires par ordre de hiérarchie.

Il n'était pas obligatoire de passer par cette "macro spéciale" mais il aurait fallu répéter 2 fois l'opération de création. Cette macro a l'avantage d'être générique et de fonctionner avec 3 répertoires ou plus au cas où mais surtout d'utiliser des méthodes bien pratiques du file system object.

Cdlt,

bonjour à tous

j'ai pas mal bosser sur la dernière proposition et trouvé des solutions entre autre pour copier vers un serveur.

Par contre, j'ai encore un petit soucis j'aimerai pouvoir ajouter dans le fichier excel qui est créé dans chaque dossiers de sous lot, 2 autres onglets en plus de feuil1

Ces onglets sont masqués dans l'exemple ( test1-v5-pour aide.xlsm) il s'agit de "enplus" et "enplus2", j'aimerai donc qu'ils soient également présents et masqués avec feuil1 dans mon fichier qui sera créer par la macro existante (ici pour l'exemple 223-1 14.10.20 21.02.03.xlsx).

merci d'avance à ceux qui prendront un moment pour m'aider

Damien

Bonjour,

Je n'ai pas testé, je vous donne la première idée, me semblant judicieuse, qui me vient, permettant de ne pas trop dénaturer le code. La macro appelée modifiée ainsi (paramètre changé et partie fileexists adaptée) :

Sub CreerDossiersFichier(Chemin$, MesFeuilles as variant) 'MACRO PARAMETREE <<< CHGT

Dim fso As FileSystemObject
Dim ws as worksheet
Dim Lecteur$, souschemin$
Dim i%
Dim Dossier

Set fso = New FileSystemObject 'instanciation du nouveau file system object
Dossier = Split(Chemin, "\") 'divise le chemin, va du lecteur (item 0) au fichier (item ubound)
Lecteur = Dossier(0) 'affectation lecteur à tester

If Not fso.DriveExists(Lecteur) Then 'si lecteur n'existe pas
    MsgBox "Le lecteur " & Lecteur & " est introuvable !!!", vbCritical, "Erreur - disque inexistant"
    Exit Sub 'sortie procédure
End If

i = 1 'initialisation i (dossier racine)
souschemin = Lecteur 'initialisation souschemin, répertoire racine
While i <= UBound(Dossier) - 1 'tant que i inf ou égal au nombre de dossiers (item ubound correspondant au fichier)
    souschemin = souschemin & "\" & Dossier(i) 'souschemin concatène le dossier enfant
    If Not fso.FolderExists(souschemin) Then 'si ce répertoire n'existe pas
        MkDir (souschemin) 'création du répertoire
    End If
    i = i + 1 'incrémentation i
Wend

If Not fso.FileExists(Chemin) Then 'si le fichier n'existe pas
    Sheets(MesFeuilles).Copy 'copie feuilles en argument '<<< CHGT
    With ActiveWorkbook
'------------------------
'essayer sans ces lignes (pas sûr qu'elles soient nécessaires) '<<< CHGT pour visibilité éventuellement
        for each ws in .worksheets
            if ws.name Like "enplus*" then
                ws.visible = False
            end if
        next ws
'------------------------
        .Close savechanges:=True, Filename:=Chemin 'fermeture et sauvegarde au nom chemin complet (<=> création fichier)
    End with
End If

End Sub

Il faut appeler cette macro comme ça dans la macro principale :

Call CreerDossiersFichier(CheminComplet, Array("nomfeuilleprincipale", "enplus", "enplus2")) '<<< adapter 1er nom !!!

Si ça ne marche pas, on avisera...

Bonne soirée,

Bonjour,

J'ai testé et la propriété de visibilité de la feuille reste inchangée à la copie. Donc ceci suffira :

Sub CreerDossiersFichier(Chemin$, MesFeuilles as variant) '<<<<<<<<<<< CHGT

Dim fso As FileSystemObject
Dim ws as worksheet
Dim Lecteur$, souschemin$
Dim i%
Dim Dossier

Set fso = New FileSystemObject 'instanciation du nouveau file system object
Dossier = Split(Chemin, "\") 'divise le chemin, va du lecteur (item 0) au fichier (item ubound)
Lecteur = Dossier(0) 'affectation lecteur à tester

If Not fso.DriveExists(Lecteur) Then 'si lecteur n'existe pas
    MsgBox "Le lecteur " & Lecteur & " est introuvable !!!", vbCritical, "Erreur - disque inexistant"
    Exit Sub 'sortie procédure
End If

i = 1 'initialisation i (dossier racine)
souschemin = Lecteur 'initialisation souschemin, répertoire racine
While i <= UBound(Dossier) - 1 'tant que i inf ou égal au nombre de dossiers (item ubound correspondant au fichier)
    souschemin = souschemin & "\" & Dossier(i) 'souschemin concatène le dossier enfant
    If Not fso.FolderExists(souschemin) Then 'si ce répertoire n'existe pas
        MkDir (souschemin) 'création du répertoire
    End If
    i = i + 1 'incrémentation i
Wend

If Not fso.FileExists(Chemin) Then 'si le fichier n'existe pas
    Sheets(MesFeuilles).Copy 'copie feuilles en argument '<<<<<<<<<<<<< CHGT
    ActiveWorkbook.Close savechanges:=True, Filename:=Chemin 'fermeture et sauvegarde au nom chemin complet (<=> création fichier)
End If

End Sub

Avec le code de gmb modifié ainsi :

Option Explicit

Sub CréerLesSousDossiers()

    Dim Chemin As String, NomHotel As String, Fichier As String, CheminComplet$
    Dim wS As Worksheet, fi As Worksheet, f1 As Worksheet
    Dim i&, y&, nb&, v, nomlot$, nom$
    Dim z As Byte
    Dim Feuillesacopier

    Application.ScreenUpdating = False
    Set fi = Sheets("inj")
    Set f1 = Sheets("Feuil1")
    Feuillesacopier = Array("Feuil1", "enplus", "enplus2") '<<<<<<CHGT

    For i = 4 To fi.Range("B" & Rows.Count).End(xlUp).Row
        nb = fi.Range("C" & i).Value

        For y = 1 To nb '+ 1
            fi.Range("B" & i).Copy f1.Range("B4")
            f1.Range("C4") = fi.Range("B" & i) & "-" & y
            fi.Range("F" & i).Copy f1.Range("D4")
            f1.Range("B12") = fi.Range("D" & i)
            f1.Range("C12") = fi.Range("E" & i)
            f1.Range("B14") = fi.Range("G" & i)
            f1.Range("C14") = fi.Range("H" & i)

            nomlot = f1.Range("C4") '& "-" '& .Cells(y, 1).Value 'nom du lot
            nom = Range("B" & i) & "\" & nomlot 'partie répertoire dossier et sous-dossier
            Chemin = "c:\lots\" & nom 'chemin répertoire
            Fichier = nomlot & " " & Format(Date, "dd.mm.yyyy") & ".xlsx" 'nom fichier
            CheminComplet = Chemin & "\" & Fichier 'nom complet du fichier
            Call CreerDossiersFichier(CheminComplet, Feuillesacopier) '<<<<<<<<CHGT
        Next y
    Next i
    f1.Range("B4:D4,B12:D12,B14:d14").ClearContents
    MsgBox "Travail terminé."
End Sub

Cdlt,

super clair comme toutes les autres fois 3GB

merci

ça marche nickel juste une petite erreur dans la macro "CreerDossiersFichier" il y a un end with qui trainait mais sinon c’est parfait merci

je vais pouvoir avancer nickel merci bcp

Damien

Parfait, je suis content que ça marche !

Oui, j'ai enlevé le with et j'ai oublié d'effacer le end with , je vais modifier mon commentaire...

Bonne continuation,