Création d'onglets a partir de 2 modèles

Question

Bonjour, j'ai récupéré un code que je n'arrive pas à modifier.

Je dois créer autant d'onglets (ici 2 par valeur) que j'ai de cellule en colonne A de la feuille Index et en 2 fois car 2 modèles (GAB_1 et GAB_2) et je dois reprendre les valeurs de la feuille de base. S'il y a des doublons en colonne A je ne prend qu'une valeur.

Lorsque je lance la macro, les onglets sont créés, les valeurs sont reprises dans le premier modèle mais pas dans le second.

Si quelqu'un a une idée.

Merci par avance

Voici le code

Sub CreeOnglets()
   Application.ScreenUpdating = False
   Set bd = Sheets("Index")
   bd.[A1].CurrentRegion.Sort Key1:=bd.Range("A2"), Order1:=xlAscending, Header:=xlGuess
   ligBD = 2
   Do While ligBD <= bd.[A65000].End(xlUp).Row
       nom = bd.Cells(ligBD, 1)       ' Premier nom

       Sheets("GAB_1").Copy After:=Sheets(Sheets.Count)
       ActiveSheet.Name = nom & "_1"
       Set plan = Sheets(nom & "_1")
       plan.Range("D5").Value = nom
       ligPlan = 9

       Do While bd.Cells(ligBD, 1) = nom   'parcours  nom traité
         TypeConges = bd.Cells(ligBD, 4)
         jours = bd.Cells(ligBD, 5)
         plan.Cells(ligPlan, 3) = bd.Cells(ligBD, 2)
         plan.Cells(ligPlan, 4) = bd.Cells(ligBD, 3)
         p = Application.Match(TypeConges, [CodesConges], 0)
         If Not IsError(p) Then plan.Cells(ligPlan, p + 4) = jours
         ligBD = ligBD + 1
         ligPlan = ligPlan + 1
      Loop

       Sheets("GAB_2").Copy After:=Sheets(Sheets.Count)
       ActiveSheet.Name = nom & "_2"
      Set plan = Sheets(nom & "_2")
       plan.Range("D5").Value = nom
       ligPlan = 9     
       Do While bd.Cells(ligBD, 1) = nom   'parcours  nom traité
         TypeConges = bd.Cells(ligBD, 4)
         jours = bd.Cells(ligBD, 5)
         plan.Cells(ligPlan, 3) = bd.Cells(ligBD, 2)
         plan.Cells(ligPlan, 4) = bd.Cells(ligBD, 3)
         p = Application.Match(TypeConges, [CodesConges], 0)
         If Not IsError(p) Then plan.Cells(ligPlan, p + 4) = jours
         ligBD = ligBD + 1
         ligPlan = ligPlan + 1
       Loop
       Loop

      End Sub

34test.xlsm (59.26 Ko)

Banzai64 · Answer

Une solution simple Rajoutes les 3 lignes surlignées Sub CreeOnglets() Dim LigDep As Long Application.ScreenUpdating = False Set bd = Sheets("Index") bd.&#91;A1&#93;.CurrentRegion.Sort Key1:=bd.Range("A2"), Order1:=xlAscending, Header:=xlGuess ligbd = 2 Do While ligbd &lt;= bd.&#91;A65000&#93;.End(xlUp).Row nom = bd.Cells(ligbd, 1) ' Premier nom Sheets("GAB_1").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = nom &amp; "_1" Set plan = Sheets(nom &amp; "_1") plan.Range("D5").Value = nom ligPlan = 9 LigDep = ligbd Do While bd.Cells(ligbd, 1) = nom 'parcours nom traité TypeConges = bd.Cells(ligbd, 4) jours = bd.Cells(ligbd, 5) plan.Cells(ligPlan, 3) = bd.Cells(ligbd, 2) plan.Cells(ligPlan, 4) = bd.Cells(ligbd, 3) p = Application.Match(TypeConges, &#91;CodesConges&#93;, 0) If Not IsError(p) Then plan.Cells(ligPlan, p + 4) = jours ligbd = ligbd + 1 ligPlan = ligPlan + 1 Loop Sheets("GAB_2").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = nom &amp; "_2" Set plan = Sheets(nom &amp; "_2") plan.Range("D5").Value = nom ligPlan = 9 ligbd = LigDep Do While bd.Cells(ligbd, 1) = nom 'parcours nom traité TypeConges = bd.Cells(ligbd, 4) jours = bd.Cells(ligbd, 5) plan.Cells(ligPlan, 3) = bd.Cells(ligbd, 2) plan.Cells(ligPlan, 4) = bd.Cells(ligbd, 3) p = Application.Match(TypeConges, &#91;CodesConges&#93;, 0) If Not IsError(p) Then plan.Cells(ligPlan, p + 4) = jours ligbd = ligbd + 1 ligPlan = ligPlan + 1 Loop Loop End Sub...