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

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

sebbbbb

XLDnaute Impliqué
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
 
Trier par date Trier par votes

youky(BJ)

XLDnaute Barbatruc
Oups! j'avais pas tout lu,
Voici la macro qui modifie les formules
Bruno
VB: 
Sub macro()
Dim n, k, tx, onglet, deb, init, nb
init = "FM" ' les 2 premi?re lettre du dernier onglet
nb = 6 'nombre d'onglet ? copier
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
End Sub
 
Vote positif 0 Vote négatif

sebbbbb

XLDnaute Impliqué
Bonjour a tous

la macro fonctionne parfaitement. Merci Youki !
je me demandais est il possible que les onglets qui sont ajoutés au fur et à mesure aient chacun une couleur différente de l'original ?
L'ideal serait d'avoir un ton légèrement plus foncé (ou plus clair) a chaque fois que l'on ajoute un jeu d'onglet

merci par avance
seb
 
Vote positif 0 Vote négatif

youky(BJ)

XLDnaute Barbatruc
Hello
Un coup bleu un coup jaune, si pas jaune changer 49407
Bruno
VB: 
Sub macro()
Dim n, k, tx, onglet, deb, init, nb, coul
init = "FM" ' les 2 premi?re lettre du dernier onglet
nb = 6 'nombre d'onglet ? copier
coul = IIf(Sheets(Sheets.Count).Tab.Color = 10656302, 49407, 10656302) 'couleur
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
ActiveSheet.Tab.Color = coul 'ici couleur d'onglet
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
End Sub
 
Vote positif 0 Vote négatif

sebbbbb

XLDnaute Impliqué
voila ce que j'ai recopié dans mon fichier

vois tu une prob qq part ?

Sub Ajouter()
Dim n, k, tx, onglet, deb, init, nb, coul
init = "FM" ' les 2 premi?re lettre du dernier onglet
nb = 6 'nombre d'onglet ? copier
ActiveWorkbook.Unprotect "BOURDAN1"
coul = IIf(Sheets(Sheets.Count).Tab.Color = 10656302, 49407, 10656302) 'couleur
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
ActiveSheet.Tab.Color = coul 'ici couleur d'onglet
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 "BOURDAN1"
End Sub
 
Vote positif 0 Vote négatif

sebbbbb

XLDnaute Impliqué
Merci a toi
bizarre chez moi, les onglets s affichent en bleu
j'ai modifié une couleur et cela fonctionne
tres etrange. peut etre ma version excel
mille merci pour ton aide et bonne sieste
 
Vote positif 0 Vote négatif

sebbbbb

XLDnaute Impliqué
Bonjour

je me permets de revenir sur cet ancien post car j'aimerai modifier le fichier 'TEST' en PJ

Je résume j'ai un bouton situé sur le 1er onglet qui me recopie les 3 premiers onglets autant de fois que je clique sur ce bouton en gardant une chronologie dans le nom des onglets

mon problème est que je voudrai ajouter un quatrième onglet (qui est donc appelé Mobile MR1) et donc modifier le code pour que celà fonctionne de façon identique avec 4 onglets plutot que trois

ci-dessous le scrip utilisé jusqu'à présent et qui doit donc etre modifie

***
Option Explicit
Dim I, II, III
Dim Ws As Worksheet
Dim WsBL As Worksheet
Dim WsPLBL As Worksheet
Dim WsCM As Object
Sub NEWblmobile()
I = 0: II = 0: III = 0
Application.ScreenUpdating = False
With ActiveWorkbook
.Unprotect ("")
For Each Ws In .Worksheets
With Ws
Select Case True
Case .Name Like "Mobile BL*"
I = I + 1
Case .Name Like "Packing List BL*"
II = II + 1
Case .Name Like "Mobile CM*"
III = III + 1
End Select
End With
Next Ws
.Sheets("Mobile BL1").Copy after:=.Sheets(.Sheets.Count)
Set WsBL = ActiveSheet
With WsBL
.Name = "Mobile BL" & 1 + I
End With
.Sheets("Packing List BL1").Copy after:=.Sheets(.Sheets.Count)
Set WsPLBL = ActiveSheet
With WsPLBL
.Name = "Packing List BL" & 1 + II
.UsedRange.Replace What:="Mobile BL" & II, Replacement:=WsBL.Name, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
Sheets("Mobile CM1").Unprotect
.Sheets("Mobile CM1").Copy after:=.Sheets(.Sheets.Count)
Set WsCM = ActiveSheet
With WsCM
.Name = "Mobile CM" & 1 + III
.UsedRange.Replace What:="Mobile BL" & II, Replacement:=WsBL.Name, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
End With
Application.ScreenUpdating = True
ActiveWorkbook.Protect ("")
End Sub

***

avec tous mes remerciements

Seb
 

Pièces jointes

  • test.xlsm
    100.6 KB · Affichages: 4
Vote positif 0 Vote négatif

youky(BJ)

XLDnaute Barbatruc
Re bonjour,
Voici
Bruno
VB: 
Option Explicit
Dim I, II, III, IV
Dim Ws As Worksheet
Dim WsBL As Worksheet
Dim WsPLBL As Worksheet
Dim WsCM As Object
Dim WsMR As Worksheet
Sub NEWblmobile()
I = 0: II = 0: III = 0: IV = 0
Application.ScreenUpdating = False
With ActiveWorkbook
   .Unprotect ("")
For Each Ws In .Worksheets
With Ws
  Select Case True
         Case .Name Like "Mobile BL*"
          I = I + 1
         Case .Name Like "Packing List BL*"
         II = II + 1
         Case .Name Like "Mobile CM*"
        III = III + 1
         Case .Name Like "Mobile MR*"
        IV = IV + 1
  End Select
End With
Next Ws
        .Sheets("Mobile BL1").Copy after:=.Sheets(.Sheets.Count)
  Set WsBL = ActiveSheet
     With WsBL
        .Name = "Mobile BL" & 1 + I
      End With
        .Sheets("Packing List BL1").Copy after:=.Sheets(.Sheets.Count)

  Set WsPLBL = ActiveSheet
     With WsPLBL
        .Name = "Packing List BL" & 1 + II
        .UsedRange.Replace What:="Mobile BL" & II, Replacement:=WsBL.Name, LookAt:=xlPart, _
           SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
              ReplaceFormat:=False
     End With
     Sheets("Mobile CM1").Unprotect
             .Sheets("Mobile CM1").Copy after:=.Sheets(.Sheets.Count)
  Set WsCM = ActiveSheet
     With WsCM
        .Name = "Mobile CM" & 1 + III
        .UsedRange.Replace What:="Mobile BL" & II, Replacement:=WsBL.Name, LookAt:=xlPart, _
           SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
              ReplaceFormat:=False
     End With
     Sheets("Mobile MR1").Unprotect
             .Sheets("Mobile MR1").Copy after:=.Sheets(.Sheets.Count)
    Set WsMR = ActiveSheet
     With WsMR
        .Name = "Mobile MR" & 1 + IV
        .UsedRange.Replace What:="Mobile BL" & II, Replacement:=WsBL.Name, LookAt:=xlPart, _
           SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
              ReplaceFormat:=False
     End With
    
End With
Application.ScreenUpdating = True
ActiveWorkbook.Protect ("")
End Sub
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
XL 2010 Prob avec sélection d'un onglet
2
Réponses
21
Affichages
2 K
sebbbbb
  • Question
XL 2010 Création et ajout d'onglets par bouton macro selon plusieurs critères
Réponses
3
Affichages
1 K
sebbbbb
B
  • Question
Copie d'un onglet existant avec ajout de date dans le nom de l'onglet
Réponses
3
Affichages
2 K
JNP
J
  • Question
Declancher un userform sur un bouton special et un prob avec le pleine ecran!
Réponses
3
Affichages
2 K
jimmy59940
J
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…