Créer plusieurs classeur en fonction d'une liste avec modèle

Bonjour,

J'ai un petit macro qui fonctionne assez bien mais j'ai besoin de le faire évoluer.

Actuellement :

- Je déclare un modèle, une liste...

- Je créer un nouveau classeur

- En fonction de la feuille "liste", j'ai le critère de la colonne B qui me permet de créer des nouvelles feuilles dans un nouveau classer.

- Les feuilles se font suivant la feuille "modèle" et se remplissent suivant les donnée de la feuille "liste".

- Les feuilles portent le nom des critère de la colonne B.

- Le nouveau classeur s'enregistre en fonction d'une cellule nouvellement remplie.

Jusqu'ici tout fonctionne mais, maintenant que j'ai fusionner plusieurs classeurs, j'aurais besoin de créer non pas 1 mais autant de classeur que la colonne 1 à de valeurs et donc de les enregistrer tous indépendamment. J'ai besoin bien sur de conserver le concept de X feuilles créer en fonction du modèle avec leur propre nom par nouveau classeur.

Et la je bloque. Je cherche à mettre un critère d'analyse mais je n'y parviens pas.

Possible de me donner un coup de pouce?

Merci :-)

(j'ai soulagé le classeur en nombre de ligne et colonne)

Bonjour Loid et bienvenu, bonjour le forum,

Pas sûr d'avoir bien compris... Si ton but est de créer autant de classeurs que d'éléments dans ta liste, le code ci-dessous devrait convenir :

Sub CreerClasseur()
Dim OM As Worksheet 'déclare la variable OM (Onglet MODELE)
Dim OL As Worksheet 'déclare la variable OL (Onglet LISTE)
Dim DL As Integer 'déclare la variable DL (Dernière Liste)
Dim I As Integer 'déclare la variable I (Incrément)
Dim NC As Workbook 'déclare la variable NC (Nouveau Classeur)
Dim NO As String 'déclare la variable NO (Nom Onglet)
Dim O As Worksheet 'déclare la variable O (Onglet)

Application.ScreenUpdating = False 'masque les rafraîchissement d'écran
Set OM = Worksheets("Modele") 'définit l'onglet OM
Set OL = Worksheets("LISTE") 'définit l'onglet OL
DL = OL.Cells(Application.Rows.Count, "A").End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne A de l'onglet OL
OM.Range("C1").Value = OL.Range("G2").Value 'récupère la valeur de G2 de l'onglet OL dans la cellule C1 de l'onglet OM
For I = 2 To DL 'boucle sur toutes les lignes I de 2 à DL
    If OL.Cells(I, "A").Value <> "" Then 'condition : si la cellule ligne I colonne A de l'onglet OL n'est pas vide
        NO = OL.Cells(I, "A").Value & " " & OL.Cells(I, "B").Value 'définit le nom de l'onglet NO
        OM.Copy 'copie l'onglet OM dans un classeur vierge
        Set O = ActiveSheet 'définit l'onglet O
        O.Name = NO 'nomme l'onglet O
        O.Range("C3").Value = OL.Cells(I, "A").Value 'récupère la valeur de la cellule ligne I colonne A de l'onglet OL dans la cellule C3 de l'onglet O
        O.Range("C5").Value = OL.Cells(I, "B").Value 'récupère la valeur de la cellule ligne I colonne B de l'onglet OL dans la cellule C5 de l'onglet O
        O.Range("C7").Value = OL.Cells(I, "C").Value 'récupère la valeur de la cellule ligne I colonne C de l'onglet OL dans la cellule C7 de l'onglet O
        Set NC = ActiveWorkbook 'définit la nouveau classeur NC
        NC.SaveAs "C:\Users\Public\" & Range("C3").Value & " " & Range("C5").Value & " " & Range("C1").Value, 51 'enregistre-sous le nouveau classeur NC
        NC.Close False 'ferme le nouveau classeur NC sans enregistrer
        Set O = Nothing 'vide la variable O
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissement d'écran
MsgBox "Classeurs créés !" 'message
End Sub

Bonjour,

Merci :-)

Je suis impressionné par la rapidité de réponse.

Ca marche, cependant j'aurais eux besoin que par exemple, tout les ballons soit regroupé dans un seul classeur mais séparé suivant leur type sur plusieurs feuilles.

Pas simple à expliquer.

Re,

Ça donnerait ça :

Sub CreerClasseur()
Dim OM As Worksheet 'déclare la variable OM (Onglet Modèle)
Dim OL As Worksheet 'déclare la variable OL (Onglet Liste)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim NC As String 'déclare la variable NC (Nom Classeur)
Dim NO As String 'déclare la variable NO (Nom Onglet)
Dim O As Worksheet 'déclare la variable O (Onglet)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OM = Worksheets("Modele") 'définit l'onglet OM
Set OL = Worksheets("LISTE") 'définit l'onglet OL
TV = OL.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données en colonne 1 de TV
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublon
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les élements J du tableau temporaire TMP
    NC = TMP(J) & " " & OL.Range("G2") 'définit le nom du classeur NC
    OM.Range("C1").Value = OL.Range("G2").Value 'récupère la valeur de G2 de l'onglet OL dans la cellule C1 de l'onglet OM
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 1) <> "" And TV(I, 1) = TMP(J) Then 'condition 1 : si la donnée ligne I colonne 1 de TV n'est pas vide et est égale à l'élément J de TMP
            NO = OL.Cells(I, "A").Value & " " & OL.Cells(I, "B").Value 'définit le nom de l'onglet NO
            On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
            Set CD = Workbooks(NC & ".xlsx") 'définit le classeur destination CD (génère une erreur si ce classeur n'est pas ouvert)
            If Err > 0 Then 'condition 2 : si une erreur a été générée
                Err.Clear 'supprime l'erreur
                OM.Copy 'copie l'onglet OM dans un classeur vierge
                Set CD = ActiveWorkbook 'définit la classeur destination CD
                CD.SaveAs "C:\Users\Public\" & NC, 51 'enregistre le classeur destination CD
                Set O = ActiveSheet 'définit l'onglet O
            Else 'sinon
                OM.Copy After:=CD.Sheets(Sheets.Count) 'copie l'onglet OM en dernière position dans le classeur CD
                Set O = ActiveSheet 'définit l'onglet O
            End If 'fin de la condition 2
            On Error GoTo 0 'annule la gestion des erreurs
            O.Name = NO 'nomme l'onglet O
            O.Range("C3").Value = OL.Cells(I, "A").Value 'récupère la valeur de la cellule ligne I colonne A de l'onglet OL dans la cellule C3 de l'onglet O
            O.Range("C5").Value = OL.Cells(I, "B").Value 'récupère la valeur de la cellule ligne I colonne B de l'onglet OL dans la cellule C5 de l'onglet O
            O.Range("C7").Value = OL.Cells(I, "C").Value 'récupère la valeur de la cellule ligne I colonne C de l'onglet OL dans la cellule C7 de l'onglet O
            Set O = Nothing 'vide la variable O
        End If 'fin de la condition
    Next I 'prochaine ligne de la boujcle
    CD.Close True 'ferme le nouveau classeur CD en enregistrant les modifications
Next J 'prochain élément de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
MsgBox "Classeurs créés !" 'message
End Sub

je sais même pas quoi dire.

Ca marche, du premiers coup et en bonus tout les commentaires pour comprendre toutes les étapes.

Merci infiniment.

Suite à l'utilisation de ce diabolique code qui donne pleine satisfaction, il apparait que cela à créer un deuxième ThisWorkbook ainsi qu'une batterie de feuille qui n'existe en fait pas:

Une capture d'écran valant mieux qu'un long discours :

Rien de grave sur le long terme?

Bonsoir Loid, bonsoir le forum,

Ces onglets sont déjà dans le fichier initial ?!... Il te suffit de les supprimer au départ...