Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

Caroline ;-))

XLDnaute Junior
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 !
 

Pièces jointes

  • 4modeles_Avec formuleFORUM.zip
    577.4 KB · Affichages: 49

benard

XLDnaute Nouveau

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

Caroline ;-))

XLDnaute Junior
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 ?
 

Pièces jointes

  • 1_depart_complexe_v1.zip
    174.3 KB · Affichages: 42

benard

XLDnaute Nouveau
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

XLDnaute Barbatruc
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

XLDnaute Nouveau
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...
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…