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

pierrejean

XLDnaute Barbatruc
Bonjour Caroline

J'ai repéré comme liens inter classeurs les cellules de type modele4 faisant référence a modele1 2 ,3
Il est possible de leur affecter une nouvelle formule faisant référence aux nouvelles feuilles
Par ailleurs bien des cellules font référence a des plages nommées .Suffit-il de les recopier en valeurs ?
 

Caroline ;-))

XLDnaute Junior
Oups, je complète ma précédente réponse :
- pour les liens entre les 4 onglets : ils devraient demeurer en lien.
- pour les cellules qui font références à des plages nommés : cela peut être des valeurs.

Merci beaucoup !
 

Caroline ;-))

XLDnaute Junior
Bonjour pierrejean,

Merci beaucoup pour ton aide.
Ta macro fonctionne parfaitement mais pourrais-tu m'expliquer le code employé pour obtenir des formules avec des adresses relatives entre les différents onglets ?
J'ai complexifié les calculs dans mon fichier joint (mais diminué le nb de régions)

Exemple : sur l'onglet "Modele4", on souhaite des liens sur des chiffres se trouvant sur les 3 précédents onglets : Ton code :
Code:
For n = 22 To 35             
    x = Range("C" & n).Formula     
    x = Replace(x, "=", "='")
    x = Replace(x, "!", "'!")
    x = Replace(x, "Modele", Left(Nom4, Len(Nom4) - 1))
    Range("C" & n).Formula = x
    Next

Que se passe-t-il quand j'ai des cellules fusionnées et que les formules sont plus complexes :

Ex1 (fusion verticale): sur l'onglet "Modele1", les cellules H15 & H16 sont fusionnées et la formule est :
=Modele2!C9+Modele2!D10+Modele2!F11-Modele3!C9
soit des additions (de chiffres situés sur l'onglet "Modele2") et une soustraction (de chiffre situé sur l'onglet "Modele3")

Mon code (qui ne fonctionne pas) :
Code:
ActiveSheet.Range("H15:H16").MergeCells = True
    n = 15                        
    x = Range("H" & n).Formula     
    x = Replace(x, "=", "='")
    x = Replace(x, "!", "'!")
    x = Replace(x, "+", "'+")
    x = Replace(x, "-", "'-")
    x = Replace(x, "Modele", Left(Nom1, Len(Nom1) - 1))
    Range("H" & n).Formula = x

Ex2 (fusion horizontale) : voir mon onglet "Modele3"
J'ai tout mis dans la macro "nSheetModeles_nClasseurs()"

Si tu pouvais m'aider, ce serait super !
Merci en tout cas.

Caroline.
 

Pièces jointes

  • 1_depart_complexe.zip
    173.5 KB · Affichages: 41

pierrejean

XLDnaute Barbatruc
Re

Je te propose une fonction personnalisée:
Code:
Function NewForm(Form, Ex, Neo)
Neo = "'" & Neo & "'"
NewForm = Replace(Form, Ex, Neo)
End Function
' A utiliser comme ceci par exemple
ActiveSheet.Range("H9:H10").MergeCells = True
n = 9                           'n: numero de ligne (fusion verticale)
x = Range("H" & n).Formula
Range("H" & n).Formula = NewForm(x, "Modele", Left(Nom1, Len(Nom1) - 1))

Si problème n’hésite pas à revenir
 

benard

XLDnaute Nouveau
Bonjour PierreJean,
Comme pour Caroline, j'ai besoin d'éclater des données en plusieurs fichiers.
J'ai récupérer une macro sur internet qui me permet de consolider plusieurs fichiers en un. Cette étape me convient.
Maintenant, et à partir de ce fichier (joint), j'ai besoin qu'il y ait un fichier txt de créer (nom du fichier=code rubrique) pour chaque rubrique (colonne D ou titre 4) avec uniquement en première colonne, les données matricule (colonne B ou titre 2) et en deuxième colonne, les données quantités (colonne E ou titre 5).
Je peux aussi me contenter de créer un fichier avec autant d'onglet que de rubrique.
Merci d'avance !
Carole
 

Pièces jointes

  • RecupDonnees NWLF.xlsm
    51.6 KB · Affichages: 34

Caroline ;-))

XLDnaute Junior
Bonjour pierrejean,
Je te remercie pour ton aide. C'est une bonne idée de créer une fonction personnalisée vu le nombre de fois que j'aurai à l'utiliser.
J'ai modifié la macro en conséquence mais cela ne fonctionne pas (encore).
Je te joins mon fichier zippé. Si tu pouvais m'aider, ce serait super !
 

Pièces jointes

  • 1_depart_complexe_v1.zip
    172.8 KB · Affichages: 44

Caroline ;-))

XLDnaute Junior
Bonjour gosselien.

Oui, pierrejean est super : il a trouvé une solution à mon souci.
La macro et la fonction permettent de traiter ces onglets "en masse".
Quant aux 140 onglets, je ne vois pas trop comment les optimiser ? 4 tableaux différents pour chacune des 35 régions...

A+
 

pierrejean

XLDnaute Barbatruc
Re
La 1ere formule n'est pas acceptée parce que la feuille a laquelle il est fait référence n'existe pas encore
Peux-tu reprendre ta macro en créant d'abord les feuilles puis en modifiant les formules
 

pierrejean

XLDnaute Barbatruc
@ Carole

Macro pour créer un fichier (à tester)

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)
   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 & "/" & "nouveau.xlsx"
w.Close
End Sub
 

benard

XLDnaute Nouveau


Waouh ! Merci PierreJean !
Serait-il possible de l'ajuster afin que les onglets ne prennent que les matricules qui ont une donné pour la rubrique concernée ? Par ailleurs il faudrait conserver la position à 8 chiffres pour les matricules
Merci encore
 

pierrejean

XLDnaute Barbatruc
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)
    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 & "/" & "nouveau4.xlsx"
W.Close
End Sub
 
Dernière édition:
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…