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

Caroline ;-)) · 27 Juillet 2017

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 :

Code:

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 · 1 Août 2017

pierrejean à dit:

Re

Voila

Code:

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 · 1 Août 2017

Re

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

benard · 1 Août 2017

Extra ! Merci Pierrejean. Vous êtes au top !

Caroline ;-)) · 1 Août 2017

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 :

Code:

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 · 1 Août 2017

Re

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

Caroline ;-)) · 2 Août 2017

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

benard · 10 Août 2017

pierrejean à dit:
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 · 10 Août 2017

Re

A tester:

Code:

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 · 10 Août 2017

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 · 11 Août 2017

Re
modif:

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

benard · 11 Août 2017

Extra ! merci infiniment PierreJean !

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

Caroline ;-))

XLDnaute Junior

Pièces jointes

benard

XLDnaute Nouveau

pierrejean

XLDnaute Barbatruc

benard

XLDnaute Nouveau

Caroline ;-))

XLDnaute Junior

Pièces jointes

pierrejean

XLDnaute Barbatruc

Pièces jointes

Caroline ;-))

XLDnaute Junior

benard

XLDnaute Nouveau

pierrejean

XLDnaute Barbatruc

benard

XLDnaute Nouveau

pierrejean

XLDnaute Barbatruc

benard

XLDnaute Nouveau

Discussions similaires