XL 2010 multiplier onglets selon liste tout en conservant liens intra-classeur

[Caroline ;-))]

Bonjour,

Je souhaiterai multiplier 4 onglets en autant qu’il y a de régions (ici 35 régions).

Au final, je devrais avoir 4 * 35 = 140 onglets.

Ma macro fonctionne bien sauf que des liens intra-classeur ne sont pas bien récupérés. Exemple : les totaux des onglets « Modele1 », « Modele2 », « Modele3 » sont repris dans l’onglet « Modele4 » (dans le tableau : Rappel)

Une fois que j’ai activé ma macro : Sub nSheetModeles_nClasseurs(), les 140 onglets sont bien créés (4 par région), mais les chiffres du rappel sont ceux qui étaient mentionnés dans les onglets de départ « Modele » et non désormais ceux des différentes régions.

Ma macro :

Sub nSheetModeles_nClasseurs()

Dim Nom1, c, Nom2, d, Nom3, e, Nom4, g

For Each c In Range("GEO_Col_AcTab1")
    Nom = c.Value
    Sheets("Modele1").Select
    Cells.Select
    Selection.Copy
    Sheets.Add Count:=1, After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Nom1
    Range("A1").Select
    ActiveSheet.Paste
    Range("C1").Value = Nom1
   
Next c

For Each d In Range("GEO_Col_AcTab2")
    Nom2 = d.Value
    Sheets("Modele2").Select
    Cells.Select
    Selection.Copy
    Sheets.Add Count:=1, After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Nom2
    Range("A1").Select
    ActiveSheet.Paste
    Range("C1").Value = Nom2
   
Next d

For Each e In Range("GEO_Col_AcTab3")
    Nom3 = e.Value
    Sheets("Modele3").Select
    Cells.Select
    Selection.Copy
    Sheets.Add Count:=1, After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Nom3
    Range("A1").Select
    ActiveSheet.Paste
    Range("C1").Value = Nom3
       
Next e

For Each g In Range("GEO_Col_AcTab4")
    Nom4 = g.Value
    Sheets("Modele4").Select
    Cells.Select
    Selection.Copy
    Sheets.Add Count:=1, After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Nom4
    Range("A1").Select
    ActiveSheet.Paste
    Range("C1").Value = Nom4
       
Next g
End Sub

Je vous joins 2 fichiers (dans mon zip) :

- Le N°1 : fichier Excel de départ : 6 onglets

- Le N° 2 : fichier Excel d’arrivé : 6 onglets +140 onglets

Mon objectif final serait d’envoyer à chaque correspondant des régions les 4 onglets qui les concerne et que les liens entre ces 4 onglets soient conservés. Mais, ici, c'est impossible car quand ils vont modifier des chiffres sur 1 onglet, cela ne va pas se répercuter sur le 4e onglet (puisque les liens entre ces 4 onglets ne fonctionnent plus).

Pouvez-vous m’aider ? Merci beaucoup !

 

[benard]

Re

Voila

Sub report()
tablo = Sheets("RecupDesDonnees").Range("A2:E" & Sheets("RecupDesDonnees").Range("A" & Rows.Count).End(xlUp).Row)
Set dico = CreateObject("Scripting.dictionary")
For n = LBound(tablo, 1) To UBound(tablo, 1)
   x = tablo(n, 4)
   If tablo(n, 5) <> "" And tablo(n, 5) <> 0 Then dico(x) = dico(x) & tablo(n, 2) & ";" & tablo(n, 5) & "|"
Next
a = dico.keys
b = dico.items
Set w = Workbooks.Add
ligne = 2
For n = LBound(a) To UBound(a)
    w.Sheets.Add.Name = a(n)
    y = Split(b(n), "|")
    For m = LBound(y) To UBound(y) - 1
        ActiveSheet.Cells(ligne, 1) = Split(y(m), ";")(0)
        ActiveSheet.Cells(ligne, 2) = Split(y(m), ";")(1)
        ligne = ligne + 1
    Next
    ligne = 2
Next
w.SaveAs ThisWorkbook.Path & "/" & "nouveau2.xlsx"
w.Close
End Sub

Génial ! et comment je peux résoudre ma position à 8 chiffres pour les matricules ?

 

[pierrejean]

Re

J'ai édité le code
cette ligne fait le job
W.ActiveSheet.Cells.NumberFormat = "@"

 

[benard]

Extra ! Merci Pierrejean. Vous êtes au top !

 

[Caroline ;-))]

Pierrejean,

J'ai beau retourné dans tous les sens et fait plusieurs essais.
J'ai pourtant déjà créé, pour chaque onglet "Modele", une nouvelle page qui porte le nom de ce qui sera repris dans la fonction.
ex :

Sheets.Add Count:=1, After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Nom1

et cela ne fonctionne pas. Est-ce que le bug pourrait provenir d'ailleurs ?

 

[pierrejean]

Re

La fonction n’était pas OK ds ts les cas
Teste cette version

 

[Caroline ;-))]

Merci beaucoup Pierrejean.
Cela marche impeccablement !
Bonne soirée.

 

[benard]

Re

J'ai édité le code
cette ligne fait le job
W.ActiveSheet.Cells.NumberFormat = "@"

Bonjour PierreJean,
Au lieu de créer un onglet par rubrique dans un seul fichier, je dois finalement créer un fichier par rubrique. Peux-tu m'aider à ajuster la macro ? Un grand merci d'avance !

Sub report()
tablo = Sheets("RecupDesDonnees").Range("A2:E" & Sheets("RecupDesDonnees").Range("A" & Rows.Count).End(xlUp).Row)
Set dico = CreateObject("Scripting.dictionary")
For n = LBound(tablo, 1) To UBound(tablo, 1)
x = tablo(n, 4)
If tablo(n, 5) <> "" And tablo(n, 5) <> 0 Then dico(x) = dico(x) & tablo(n, 2) & ";" & tablo(n, 5) & "|"
Next
a = dico.keys
b = dico.items
Set W = Workbooks.Add
ligne = 1
For n = LBound(a) To UBound(a)
W.Sheets.Add.Name = a(n)
W.ActiveSheet.Cells.NumberFormat = "@"
y = Split(b(n), "|")
For m = LBound(y) To UBound(y) - 1
ActiveSheet.Cells(ligne, 1) = Split(y(m), ";")(0)
ActiveSheet.Cells(ligne, 2) = Split(y(m), ";")(1)
ligne = ligne + 1
Next
ligne = 2
Next
W.SaveAs ThisWorkbook.Path & "/" & "nouveau2.xlsx"
W.Close
End Sub

 

[pierrejean]

Re

A tester:

Sub reportb()
tablo = Sheets("RecupDesDonnees").Range("A2:E" & Sheets("RecupDesDonnees").Range("A" & Rows.Count).End(xlUp).Row)
Set dico = CreateObject("Scripting.dictionary")
For n = LBound(tablo, 1) To UBound(tablo, 1)
   x = tablo(n, 4)
   dico(x) = dico(x) & tablo(n, 2) & ";" & tablo(n, 5) & "|"
Next
a = dico.keys
b = dico.items
'Set w = Workbooks.Add
ligne = 2
For n = LBound(a) To UBound(a)
  Workbooks.Add
    y = Split(b(n), "|")
    For m = LBound(y) To UBound(y) - 1
        ActiveSheet.Cells(ligne, 1) = Split(y(m), ";")(0)
        ActiveSheet.Cells(ligne, 2) = Split(y(m), ";")(1)
        ligne = ligne + 1
    Next
    ligne = 2
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & a(n)
    ActiveWorkbook.Close
Next
'w.SaveAs ThisWorkbook.Path & "/" & "nouveau.xlsx"
'w.Close
End Sub

 

[benard]

Genial ! il me manque plus que la première colonne des fichiers qui comporte les matricules qui doivent rester en texte. J'essaie d'intégrer ton code
W.ActiveSheet.Cells.NumberFormat = "@"
Mais cela me met l'action en erreur. Je dois mal le positionner dans la chaine...

 

[pierrejean]

Re
modif:

Workbooks.Add
Activesheet.Cells.NumberFormat="@"
y = Split(b(n), "|")

 

[benard]

Extra ! merci infiniment PierreJean !