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 !

pierrejean · 27 Juillet 2017

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 ;-)) · 27 Juillet 2017

Bonjour pierrejean,
Je préfère que cela soit plutôt des liens (et non des valeurs).
Merci !

Caroline ;-)) · 27 Juillet 2017

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 !

pierrejean · 28 Juillet 2017

Re

A tester

Caroline ;-)) · 31 Juillet 2017

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.

pierrejean · 1 Août 2017

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

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

Caroline ;-)) · 1 Août 2017

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 !

gosselien · 1 Août 2017

Bonjour,

Faudra m'expliquer comment on gère 140 onglets....
Tableau de base mal fagoté au départ je pense

P.
@pierrejean est bien courageux

Caroline ;-)) · 1 Août 2017

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

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

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

pierrejean à dit:

@ 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

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

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

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

Caroline ;-))

XLDnaute Junior

Pièces jointes

pierrejean

XLDnaute Barbatruc

Caroline ;-))

XLDnaute Junior

Caroline ;-))

XLDnaute Junior

pierrejean

XLDnaute Barbatruc

Pièces jointes

Caroline ;-))

XLDnaute Junior

Pièces jointes

pierrejean

XLDnaute Barbatruc

benard

XLDnaute Nouveau

Pièces jointes

Caroline ;-))

XLDnaute Junior

Pièces jointes

gosselien

XLDnaute Barbatruc

Caroline ;-))

XLDnaute Junior

pierrejean

XLDnaute Barbatruc

pierrejean

XLDnaute Barbatruc

benard

XLDnaute Nouveau

pierrejean

XLDnaute Barbatruc

Discussions similaires