Création de classeurs et onglets selon une liste et d'après un modèle

[abouilies]

Bonsoir à tous,
J'ai trouvé le code dans la PJ sur ce forum qui me permet de créer un nouveau classeur et différents onglets selon une feuille "données".
Ce code fonctionne très bien.
Je souhaiterai que l'ensemble de la création se fasse d'après un onglet modèle (dans la PJ, l'onglet s'intitule "modele")
Ayant des connaissances très limitées en VBA et je teste depuis ce matin, je vous remercie pour l'attention portée à cette demande.
Et si quelqu'un peut m'apporter ses lumières, ce serait formidable !
Merci à tous ceux qui font vivre ce site. (ceux qui sont dans le besoin et ceux qui y répondent)
en PJ le fichier avec ses 2 onglets.

Abouilies

 

[Staple1600]

Re : Création de classeurs et onglets selon une liste et d'après un modèle

Bonsoir à tous


Ne pouvant ouvrir actuellement les*.xlsm
voici un petit exemple

Sub a()
Dim t, i As Byte
t = Sheets("Liste").[A1].CurrentRegion.Value
For i = LBound(t) To UBound(t)
Sheets("MODELE").Copy after:=Sheets(Worksheets.Count)
ActiveSheet.Name = t(i, 1)
Next
End Sub

Sur la feuille Liste, il y a en colonne A (sans trous) les noms des futurs onglets (qui seront la copie de la feuille nommée MODELE)

PS: Est-ce que cet éclairage aura été suffisant ?

 

[abouilies]

Re : Création de classeurs et onglets selon une liste et d'après un modèle

Bonsoir Staple1600,

voici les deux macros :

Sub Test()
MonChemin = ThisWorkbook.Path
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("données")
    .Range("IS1:IV65536").Clear 'Nettoyage des zones de critères
    .Cells.Sort Key1:=.Range("A2"), Key2:=.Range("B2"), Header:=xlYes, DataOption2:=xlSortTextAsNumbers 'Tri de la base pour supprime rles eventuelles lignes vides et trier les critères
    .Range("A1").CurrentRegion.Resize(, 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("IS1"), Unique:=True 'Extraction du nb et des noms des classeurs à créer
    .Range("A1").CurrentRegion.Resize(, 2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("IU1"), Unique:=True 'Extraction des noms de Feuilles à créer dans les classeurs
    For Each X In .Range(.Range("IS2"), .Range("IS2").End(xlDown)) 'Boucle sur les noms de classeurs
        Application.DisplayAlerts = False 'Suppression des messages pour éviter les question en cas d'ecrasement d'un fichier deja existant
        Set MonCLass = Workbooks.Add 'Creation du classeur
        MonCLass.SaveAs Filename:=MonChemin & "\" & X 'On nomme le classeur
        Application.DisplayAlerts = True 'Réactivation des messages
        For i = 1 To Application.CountIf(.Columns(255), X) 'Boucle sur le nb de feuilles par classeur
            Set MaFeuille = MonCLass.Sheets.Add(after:=MonCLass.Sheets(MonCLass.Sheets.Count))  'On ajoute une feuille
            MaFeuille.Name = .Range("IV2").Value 'On la nomme avec le critere IV2 (critere Code Entreprise)
            .Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("IU1:IV2"), CopyToRange:=MaFeuille.Range("A1") 'Filtre élaboré directement dans la feuille destination fraichement créée)
            'Remarque : la zone decriteres est : .Range("IU1:IV2"). Elle ne change pas cf. ***
            MaFeuille.Cells.EntireColumn.AutoFit 'Ajustement des colonnes
            .Range("IU2:IV2").Delete '*** on supprime les lignes au fur et à mesure pour que les criteres evoluent
        Next
        Nettoyeur MonCLass 'On enleve Feuil1, Feuil2 etc ...
        MonCLass.Close True 'On ferme le classeur
    Next
.Range("IS1:IV65536").Clear 'Nettoyage des zones de critères
End With
Application.ScreenUpdating = True
End Sub


Sub Nettoyeur(Arg1)
Application.DisplayAlerts = False
For Each Y In Arg1.Sheets
    If Left(Y.Name, 5) = "Feuil" Then Y.Delete
Next
Application.DisplayAlerts = True
End Sub

A la lecture de votre code, effectivement la création d'onglet se fait bien d'après le modèle. Seulement, je voudrai que la création du nouveau classeur (avec le nom en A1) ainsi que ses onglets (avec le nom en B1) : les onglets auront comme structure la feuille intitulé "modèle", tout cela en une seule opération.

Merci encore.

Abouilies