XL 2010 Dupliquer a loisir des onglets par bouton macro

[sebbbbb]

Bonjour

je viens faire appel à vos connaissances sur un sujet dont je bute depuis plusieurs semaines. j'ai eu de l'aide par certains d'entre vous mais j'ai toujours un ptit qq chose qui cloche aussi j'aimerai repartir de zéro.

voici donc ce que je cherche :

- j'ai sélectionné d'un gros fichier existant qui me sert de fichier test 4 onglets
- je souhaiterai que lorsque je clique sur le bouton "NEW" situé sur l'onglet SWB1, 4 nouveaux onglets s'affichent à la suite avec le même nom mais en ayant juste le nbre qui diffère. Ainsi à la suite des onglets SWB1, PCK1, CMA1, REI1 s'affichent les nouveaux onglets SWB2, PCK2, CMA2, REI2 et ainsi de suite autant de fois que l'on clique sur le bouton (SWB3, PCK3, CMA3, REI3 etc etc)

Certains d'entre vous m'on aidé dans cette tâche et cela fonctionne plutôt bien.

Seul hic, dont je me suis rendu compte ultérieurement c'est que les nouveaux onglets gardent les liens aux onglets originaux.

Je m'explique :
- si je prends pour exemple l'onglet CMA1, il y a des liens entres les cellules de cet onglet et celui SWB1 ; idem entre l'onglet PCK1 et SWB1 ou entre REI1 et SWB1
- j'aimerai que les liens restent identiques mais par contre entre les nouveaux onglets c'est à dire entre CMA2 et SWB2, PCK2 et SWB2 ou REI2 et SWB2

C'est la tout mon problème car actuellement les liens restent entre CMA2 et SWB1, PCK2 et SWB1 ou REI2 et SWB1 et ainsi de suite avec les autres onglets ; ce qui fausse complètement mes données

J'espère m'être exprimé clairement et que vous pourrez m'apporter votre aide

un énorme merci à vous qui vous pencherez dessus. j'avoue que cela m'enlèverait une grosse épine du pied

Seb

 

[sebbbbb]

j'espère que mes explications étaient suffisantes
merci par avance

 

[Dranreb]

Bonjour.
Ce code placé dans un module standard a l'air de faire le job, la macro BtnNew étant affectée à la forme dessinée "New" :

Option Explicit

Sub BtnNew()
   Dim TWsh(1 To 8) As Worksheet, N As Long, NomF, Rng As Range, M As Long, AdrSrc As String, AdrCbl As String
   Set TWsh(1) = ActiveSheet
   For N = 2 To 4
      Set TWsh(N) = ThisWorkbook.Worksheets(TWsh(1).Index - 1 + N)
      Next N
   For N = 5 To 8
      TWsh(N - 4).Copy After:=TWsh(N - 1)
      Set TWsh(N) = ActiveSheet
      NomF = TWsh(N - 4).Name
      TWsh(N).Name = Left$(NomF, Len(NomF) - 1) & Right$(NomF, 1) + 1
      Next N
   For N = 5 To 8
      Set Rng = TWsh(N).Cells.SpecialCells(xlCellTypeFormulas, 23)
      For M = 1 To 4
         AdrSrc = TWsh(M).[A1].Address:     AdrSrc = Left$(AdrSrc, InStr(AdrSrc, "!"))
         AdrCbl = TWsh(M + 4).[A1].Address: AdrCbl = Left$(AdrCbl, InStr(AdrCbl, "!"))
         Rng.Replace What:=AdrSrc, Replacement:=AdrCbl, LookAt:=xlPart, SearchOrder:=xlByRows, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
         Next M, N
   TWsh(1).Shapes(Application.Caller).Delete
   End Sub

Cela dit je ne ferais probablement pas comme ça, je pense. J'essayerais de constituer une base de donnée avec tout dedans, et un dispositif pour en extraire une partie, toujours dans les mêmes 4 feuilles.

Édition: J'ai modifié le code pour diminuer le risque, déjà infime, de remplacer un texte conforme à un nom de feuille mais étranger à une référence de plage bien que figurant dans une formule. J'ai par ailleurs ajouté à la fin une instruction qui supprime la forme qui a lancé la macro, car celle ci planterait, logiquement, si on la réutilisait. La forme figure bien entendu sur la nouvelle copie.

 

[sebbbbb]

merci beaucoup
j'essaie ce soir et te reviens
seb

 

[sebbbbb]

hello

le principe fonctionne bien

seul hic comme je le mentionnais j'aimerai que les liens restent identiques mais par contre entre les nouveaux onglets c'est à dire entre CMA2 et SWB2, PCK2 et SWB2 ou REI2 et SWB2

avec ton script les les liens restent entre CMA2 et SWB1, PCK2 et SWB1 ou REI2 et SWB1 et ainsi de suite avec les autres onglets ; ce qui fausse complètement mes données

peux tu y remédier stp ?
merci
seb

 

[Dranreb]

Ben normalement non, les références aux anciennes feuilles sont corrigées en références aux nouvelles.
Attention: ça ne marche pas si les nouvelles feuilles existent déjà. C'est pour cela qui j'ai ajouté une instruction à la fin pour supprimer la forme qui a lancé la macro.

 

[sebbbbb]

merci
pourtant j'ai un code qui fonctionne bien comme celà mais que je n'arrive pas à adapter pour ces 4 autres onglets

 

[Dranreb]

Ah, non, j'ai rouvert ton classeur (je ne l'avais pas gardé), réinstallé la macro, et vu que ça ne marche plus.
Je vais voir ce qui se passe.

Vu. J'avais oublier un argument à la méthode Address pour récupérer le nom de la feuille.
Voici le code corrigé :

Option Explicit

Sub BtnNew()
   Dim TWsh(1 To 8) As Worksheet, N As Long, NomF, Rng As Range, M As Long, AdrSrc As String, AdrCbl As String
   Set TWsh(1) = ActiveSheet
   For N = 2 To 4
      Set TWsh(N) = ThisWorkbook.Worksheets(TWsh(1).Index - 1 + N)
      Next N
   For N = 5 To 8
      TWsh(N - 4).Copy After:=TWsh(N - 1)
      Set TWsh(N) = ActiveSheet
      NomF = TWsh(N - 4).Name
      TWsh(N).Name = Left$(NomF, Len(NomF) - 1) & Right$(NomF, 1) + 1
      Next N
   For N = 5 To 8
      Set Rng = TWsh(N).Cells.SpecialCells(xlCellTypeFormulas, 23)
      For M = 1 To 4
         AdrSrc = TWsh(M).[A1].Address(External:=True)
         AdrCbl = TWsh(M + 4).[A1].Address(External:=True)
         AdrSrc = Mid$(AdrSrc, InStr(AdrSrc, "]") + 1): AdrSrc = Left$(AdrSrc, InStr(AdrSrc, "!"))
         AdrCbl = Mid$(AdrCbl, InStr(AdrCbl, "]") + 1): AdrCbl = Left$(AdrCbl, InStr(AdrCbl, "!"))
         Rng.Replace What:=AdrSrc, Replacement:=AdrCbl, LookAt:=xlPart, SearchOrder:=xlByRows, _
            MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
         Next M, N
   TWsh(1).Shapes(Application.Caller).Delete
   End Sub

 

[sebbbbb]

Dranreb

qu'entends tu par :
les références aux anciennes feuilles sont corrigées en références aux nouvelles.

car si je prends un cellule dans par exemple CMA2 elle fait toujours ref a SWB1 et non pas SWB2

Vois tu ce que je veux dire ?

merci
seb

 

[Dranreb]

Voir corrections au poste précédent.

 

[sebbbbb]

Merci Dranreb
je crois nos messages se sont croisés
j'ai mis a jour ton scrip mais même résultat
peux tu m'envoyer le fichier stp
merci bcp
seb

 

[Dranreb]

Alors là je ne comprends vraiment pas pourquoi dans tes formules les noms des feuilles sont encadrées d'apostrophes, alors que dans les .[A1].Address(External:=True) elles ne le sont pas.
Changement de fusil d'épaule :

Sub BtnNew()
   Dim TWsh(1 To 8) As Worksheet, N As Long, NomF, Rng As Range, M As Long, NSrc As String, NCbl As String
   Set TWsh(1) = ActiveSheet
   For N = 2 To 4
      Set TWsh(N) = ThisWorkbook.Worksheets(TWsh(1).Index - 1 + N)
      Next N
   For N = 5 To 8
      TWsh(N - 4).Copy After:=TWsh(N - 1)
      Set TWsh(N) = ActiveSheet
      NomF = TWsh(N - 4).Name
      TWsh(N).Name = Left$(NomF, Len(NomF) - 1) & Right$(NomF, 1) + 1
      Next N
   For N = 5 To 8
      Set Rng = TWsh(N).Cells.SpecialCells(xlCellTypeFormulas, 23)
      For M = 1 To 4
'         AdrSrc = TWsh(M).[A1].Address(External:=True)
'         AdrCbl = TWsh(M + 4).[A1].Address(External:=True)
'         AdrSrc = Mid$(AdrSrc, InStr(AdrSrc, "]") + 1): AdrSrc = Left$(AdrSrc, InStr(AdrSrc, "!"))
'         AdrCbl = Mid$(AdrCbl, InStr(AdrCbl, "]") + 1): AdrCbl = Left$(AdrCbl, InStr(AdrCbl, "!"))
         NSrc = TWsh(M).Name: NCbl = TWsh(M + 4).Name
         Rng.Replace What:=NSrc & "!", Replacement:=NCbl & "!", _
            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
         Rng.Replace What:="'" & NSrc & "'!", Replacement:="'" & NCbl & "'!", _
            LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
         Next M, N
   TWsh(1).Shapes(Application.Caller).Delete
   End Sub

 

[sebbbbb]

Génial !

je désespérai de ne pas pouvoir trouver de solution
je refais des tests a tête reposée ce soir, mais le peu que j'ai vu cela semble parfait
je te redis au plus vite

un énorme merci pour ton aide

Seb

 

[sebbbbb]

MERDUM

lorsque j'adapte ton scrip a mon fichier j'ai une erreur

y comprends tu qq chose ?

 

[sebbbbb]

est ce que le fait d'avoir la possibilité d'avoir des onglets devant ou derriere peut etre la cause ?

merci par avance
seb