XL 2010 intégrer plusieurs fois le même onglet (avec nom leg différent) a un classeur par macro bouton

[sebbbbb]

Bonsoir tout le monde

j'ai un problème à vous soumettre qui me semble insurmontable . Mais avec vous je sais que rien n'est impossible.

Voila j'ai une macro qui marche avec un bouton. Lorsque je clique sur le bouton, plusieurs onglets qui sont cachés apparaissent dans mon classeur. jusque là tout marche parfaitement

Est il possible que lorsque je clique a nouveau sur le même bouton les mêmes onglets s'ajoutent en plus des autres avec un nom d'onglets légèrement différent.

Voici mon code actuel :

Option Explicit
Sub blcmmobile()
'
' blcmmobile Macro
'
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect ("")
Sheets("BL1").Visible = True
Sheets("Packing List BL1").Visible = True
Sheets("CM1").Visible = True
Sheets("BL1 ").Select
Range("BM3:BN3").Select
ActiveWorkbook.Protect ("")
Application.ScreenUpdating = True
End Sub

Ainsi lorsque je clique sur mon bouton j'ai 3 onglets qui apparaissent avec le nom et l'ordre suivant :
- BL1
- Packing List BL1
- CM1

peut on modifier le script de façon à ce que lorsque je clique à nouveau sur le même bouton apparaissent à la suite des onglets ci-dessus 3 autres appelés :
- BL2
- Packing List BL2
- CM2

et ainsi de suite :
- BL3
- Packing List BL3
- CM3

Un grand merci par avance pour votre aide

seb

 

[sebbbbb]

Tu m'avais créé ce scrip qui marche bien pour un autre jeu de 6 onglets; peux tu l'adapter pour mes 4 onglets stp :
- SWB1
- PCK1
- CMA1
- REC1

**

Sub NEWblmobile()
Dim n, k, tx, onglet, deb, init, nb
init = "FM" ' les 2 premi?re lettre du dernier onglet
nb = 6 'nombre d'onglet ? copier
ActiveWorkbook.Unprotect ""
For k = Sheets.Count To 1 Step -1
If Left(Sheets(k).Name, 2) = init Then
deb = k
n = Val(Replace(Sheets(k).Name, init, ""))
tx = Replace(Sheets(k).Name, n, n + 1)
Exit For
End If
Next
For k = deb - nb + 1 To deb
Sheets(k).Copy after:=Sheets(Sheets.Count)
tx = Replace(Sheets(k).Name, n, n + 1)
ActiveSheet.Name = tx
If Left(tx, 2) <> "BL" Then
ActiveSheet.Unprotect
For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
c.Formula = Replace(c.Formula, "BL impr." & n, "BL impr." & n + 1)
c.Formula = Replace(c.Formula, "Man" & n, "Man" & n + 1)
Next
End If
Next
ActiveWorkbook.Protect ""
End Sub

**

merci
seb

 

[youky(BJ)]

Bonsoir,
Essaye comme ceci
Bruno

Sub NEWblmobile()
Dim n, k, tx, onglet, deb, init, nb
init = "RE" ' les 2 premiere lettre du dernier onglet
nb = 4 'nombre d'onglet ? copier
ActiveWorkbook.Unprotect ""
For k = Sheets.Count To 1 Step -1
If Left(Sheets(k).Name, 2) = init Then
deb = k
n = Val(Replace(Sheets(k).Name, init, ""))
tx = Replace(Sheets(k).Name, n, n + 1)
Exit For
End If
Next
For k = deb - nb + 1 To deb
Sheets(k).Copy after:=Sheets(Sheets.Count)
tx = Replace(Sheets(k).Name, n, n + 1)
ActiveSheet.Name = tx
 'If Left(tx, 2) <> "BL" Then
    'ActiveSheet.Unprotect
'                                                             ici c'est pour modifier les formules
       'For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
           'c.Formula = Replace(c.Formula, "BL impr." & n, "BL impr." & n + 1)
           'c.Formula = Replace(c.Formula, "Man" & n, "Man" & n + 1)
       'Next
 'End If
Next
ActiveWorkbook.Protect ""
End Sub

 

[sebbbbb]

Merci
Helas cela ne fonctionne pas et je pense que c est normal cela le scrip fait ref a d autres onglets.

L as tu teste sur mon fichier envoye en pj ?

Merci par avance
Seb

 

[sebbbbb]

en PJ mon fichier test
merci par avance

 

[youky(BJ)]

Voici,
Je ne m'occupe plus des formules (je sais pas)
Bruno

Tu m'avais donné comme dernier onglet REC1 et c'est REI1

Sub NEWblmobile()
Dim n, k, tx, onglet, deb, init, nb
'retifié cette ligne
init = "REI" ' les lettre du dernier onglet sans le chiffre
nb = 4 'nombre d'onglet ? copier
ActiveWorkbook.Unprotect ""
For k = Sheets.Count To 1 Step -1
If Left(Sheets(k).Name, 3) = init Then 'mis 3 au lieu de 2
deb = k
n = Val(Replace(Sheets(k).Name, init, ""))
tx = Replace(Sheets(k).Name, n, n + 1)
Exit For
End If
Next
For k = deb - nb + 1 To deb
Sheets(k).Copy after:=Sheets(Sheets.Count)
tx = Replace(Sheets(k).Name, n, n + 1)
ActiveSheet.Name = tx
'If Left(tx, 2) <> "BL" Then
    'ActiveSheet.Unprotect
'                                                             ici c'est pour modifier les formules
       'For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
           'c.Formula = Replace(c.Formula, "BL impr." & n, "BL impr." & n + 1)
           'c.Formula = Replace(c.Formula, "Man" & n, "Man" & n + 1)
       'Next
'End If
Next
ActiveWorkbook.Protect ""
End Sub

 

[sebbbbb]

bonjour Youky

en fait le problème vient que dans le code en marron, cela fait ref a des onglets qui ne sont pas dans mon fichier test notamment les onglets BL, BL impr. ou l'onglet Man

c'est pour celà que je t'ai envoyé mon fichier 'testfichier' qui lui a pour onglet a prendre comme ref

- SWB1
- PCK1
- CMA1
- REI1

je te remercie sincèrement par avance

Seb

 

[sebbbbb]

re bonjour Youky

merci enormément pour ton aide

j'ai retravaillé le scrip selon tes indications et cela fonctionne bien pour la duplication

helas il reste un hic (ce serait trop simple ) 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 a toi

seb

 

[youky(BJ)]

Dur à comprendre
Voici je pense être OK
Bruno

 

[sebbbbb]

Merci beau coup Bruno pour ton aide et ta patience
je teste cela ce soir et te redis
Seb

 

[sebbbbb]

Bonsoir Youki

revoila le casse pieds de service

merci encore pour ton boulot qui me ravit
j'aurai juste une dernière requete si cela est faisable de ton coté

Tous les liens entre les feuilles fonctionnent parfaitement bien sauf sur le 1er onglet "SWB1" et donc ses duplicats

je m'explique

si tu prends la cellule AX33 dans l'onglet SWB1, elle est liée à la cellule B42 de l'onglet PCK1 ; apres duplication la cellule AX33 de l'onglet SWB2 devrait être liée à la cellule B42 de l'onglet PCK2, ce qui n'est pas le cas (elle reste liée à la cellule B42 de l'onglet PCK1)

Puis je a nouveau abuser de ta gentillesse et de tes connaissances ?

merci à toi Youki
seb

 

[youky(BJ)]

Hello,
En AX33 de l'onglet SWB1 j'ai 4,00Kg
Je pense que les formules ont disparues
En B42 de PCK1 j'ai je pense affaire à une funtion.
ici que j'ai laissé en vert dans la macro
'c.Formula = Replace(c.Formula, "Man" & n, "Man" & n + 1)
dans cette exemple on remplace Man1 par Man2
Man est le nom de l'onglet sans le chiffre
Fait des essais en tout genre en enlevant l'apostrophe
Bruno

 

[sebbbbb]

Bonjour Youky
Je ne comprends pas bien ton message.
Il faut changer le script c est bien cela ?
Merci
Seb

 

[sebbbbb]

je vois ce que tu veux dire (enfin je crois ) mais ce qui est étonnant c'est que le hic correspond au 1er onglet "SWB1" et donc ses duplicats pourtant tu as déjà mis la formule magique :

c.Formula = Replace(c.Formula, "BL Mobile" & n, "BL Mobile" & n + 1)

qui si j'ai bien compris fait les modif pour que les liens entre cellules se fassent en fonction des noms des onglets donc dans l'exemple évoqué ci-dessus la cellule AX33 de l'onglet SWB2 devrait être liée à la cellule B42 de l'onglet PCK2, ce qui n'est pas le cas (elle reste liée à la cellule B42 de l'onglet PCK1)

merci à toi

quel casse-tête

Seb

 

[sebbbbb]

En fait pour donner un autre exemple, j'aimerai que, après duplication, la cellule C30 de SWB2 fasse ref à la cellule B42 de l'onglet PCK2 et non pas de PCK1

 

[youky(BJ)]

C'était pourtant facile . . .
voici à tester
Bruno

Sub NEWblmobile()
Dim n, k, tx, onglet, deb, init, nb
'retifié cette ligne
init = "REI" ' les lettre du dernier onglet sans le chiffre
nb = 4 'nombre d'onglet ? copier
ActiveWorkbook.Unprotect ""
For k = Sheets.Count To 1 Step -1
If Left(Sheets(k).Name, 3) = init Then 'mis 3 au lieu de 2
deb = k
n = Val(Replace(Sheets(k).Name, init, ""))
tx = Replace(Sheets(k).Name, n, n + 1)
Exit For
End If
Next
For k = deb - nb + 1 To deb
Sheets(k).Copy after:=Sheets(Sheets.Count)
tx = Replace(Sheets(k).Name, n, n + 1)
ActiveSheet.Name = tx
 If Left(tx, 3) <> "SWB" Then
    ActiveSheet.Unprotect
'                        ici c'est pour modifier les formules
       For Each c In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
           c.Formula = Replace(c.Formula, "SWB" & n, "SWB" & n + 1)
           c.Formula = Replace(c.Formula, "PCK" & n, "PCK" & n + 1)
       Next
 End If
Next
ActiveWorkbook.Protect ""
End Sub