copie d'onglets

[fostier]

bonjour a tous
je souhaite copier des onglets avec cette formule

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "B5" And Target.Text <> vbNullString Then ActiveSheet.Name = Target.Text
End Sub

mon problème est que je souhaiterais que le nom de la personne dans l'onglet nom du personnel apparaisse directement dans l'onglet dupliqué sans devoir modifier les formules manuellement B5 C5 D5 de l'onglet dupliqué

pouvez vous m'aider

merci d'avance

 

[mapomme]

Re : copie d'onglets

Bonjour fostier,

Un essai via VBA qui:

• Si on insère un nom en colonne B (ligne 3 à 28) qui n'a pas d'onglet correspondant, on crée un onglet avec ce nom et on y applique les formules en D5,F5 et G5 (nom, prénom, fonction).
• Si on modifie un nom dont l'onglet existe déjà, alors on modifie le nom de l'onglet.
• Si on supprime un nom alors l'onglet correspondant est détruit (après confirmation par l'utilisateur)

• On utilise une feuille "Modele" pour créer les nouveaux onglets
• Le code est entièrement situé dans le module de la feuille "noms du personnel".

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet, ThisSH As Worksheet
Dim xCell As Range, Renomme As Boolean

Application.EnableEvents = False
Application.ScreenUpdating = False
Set ThisSH = ActiveSheet
If Not Intersect(Target, Range("b3:b28")) Is Nothing Then
  'pour chaque cellule modifiée
  For Each xCell In Intersect(Target, Range("b3:b28"))
    Renomme = False
    'pour chaque feuille du classeur
    For Each sh In Worksheets
      'recherche de la feuille correspondante
      If sh.Range("B5").FormulaLocal = "=NOMPROPRE('noms du personnel'!B" & xCell.Row & ")" Then
        'c'est une feuille planning individuelle qui correspond au nom de la ligne traitée
        'on change son nom
        If Trim(xCell.Text) <> "" Then
          sh.Name = sh.Range("B5").Text
          Renomme = True
        Else
          'le nom est vide - on pourrait ici détruire ou archiver la feuille
          If MsgBox("Détruire la feuille [" & sh.Name & "] ?", vbCritical + vbYesNo + vbDefaultButton2) = vbYes Then
            sh.Delete
            Renomme = True
          End If
        End If
        If Renomme Then Exit For
      End If
    Next sh
    If Not Renomme Then
      'on copie la feuille modèle
      If Trim(xCell.Text) <> "" Then
        Sheets("Modele").Copy After:=Sheets(Sheets.Count)
        'On applique les bonnes formules
        ActiveSheet.Range("B5").FormulaLocal = "=" & Replace(Sheets("Modele").Range("B5").FormulaLocal, 999999, xCell.Row)
        ActiveSheet.Range("D5").FormulaLocal = "=" & Replace(Sheets("Modele").Range("D5").FormulaLocal, 999999, xCell.Row)
        ActiveSheet.Range("G5").FormulaLocal = "=" & Replace(Sheets("Modele").Range("G5").FormulaLocal, 999999, xCell.Row)
        ActiveSheet.Name = ActiveSheet.Range("B5").Text
      End If
    End If
  Next xCell
End If
ThisSH.Activate
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[fostier]

Re : copie d'onglets

merci mapomme c'est genial un grand bravo c'est exactement ce que je voulais si je souhaite mettre plus de 28 noms est bien ces lignes que je dois modifier
If Not Intersect(Target, Range("b3:b28")) Is Nothing Then
'pour chaque cellule modifiée
For Each xCell In Intersect(Target, Range("b3:b28"))
en particulier B28 ?
encore bravo et merci

 

[mapomme]

Re : copie d'onglets

(re)Bonjour fostier,

si je souhaite mettre plus de 28 noms est bien ces lignes que je dois modifier
If Not Intersect(Target, Range("b3:b28")) Is Nothing Then
'pour chaque cellule modifiée
For Each xCell In Intersect(Target, Range("b3:b28"))
en particulier B28 ?

C'est exactement cela. Si dans la colonne B, il n'y aura jamais d'autres données que des noms, tu peux directement remplacer les 28 par 10000 et tu seras tranquille! (à moins d'avoir plus de 10000 employés). Cela n'augmentera pas le temps d'exécution!

 

[fostier]

Re : copie d'onglets

super et merci j’espère ne pas avoir 10000 employés a gérer lollllllll encore merci et bravo a+++++++++++++++++