Copie automatique feuille type

Benoit DESCOURS

XLDnaute Junior
Bonjour,

J'ai une première feuille qui liste du personnel et qui s'appelle "PERSONNEL".
Je retrouve 2 colonnes, en A, j'ai les Noms et en B j'ai les Prénoms.

J'ai une feuille type qui se nomme "Salarié XX" avec un cadre défini.

J'aimerais lorsque je rajoute dans ma feuille "PERSONNEL" un nouveau qui s’appelle "MACHIN Truc", une copie se fasse de ma feuille type qui se nomme "Salarié XX" et qui se nomme automatiquement "MACHIN Truc".

Merci de vos retours très pédagogiques car je ne maîtrise pas vraiment les macros...

Benoit.
 

job75

XLDnaute Barbatruc
Bonjour Benoit DESCOURS,

Clic droit sur l'onglet "PERSONNEL puis sur "Visualiser le code" et collez cette macro :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, x$
Set r = Intersect(Target, Range("A2:B" & Rows.Count), UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next 'si la feuille n'existe pas
For Each r In Intersect(r.EntireRow, [A:B]).Rows 'si entrées multiples (copier-coller)
    If r.Cells(1) <> "" And r.Cells(2) <> "" Then 'il faut le nom et le prénom
        x = r.Cells(1) & " " & r.Cells(2)
        If IsError(Sheets(x)) Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = x
    End If
Next
Me.Activate
End Sub
La macro s'exécute quand le nom et le prénom ont été entrés en colonnes A et B.

Edit : salut M12, pas rafraîchi.

A+
 

job75

XLDnaute Barbatruc
Re, salut à JBARBE que je n'avais pas vu,

Bah j'avais zappé le fait qu'il fallait copier la feuille "Salarié XX" :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, x$
Set r = Intersect(Target, Range("A2:B" & Rows.Count), UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next 'si la feuille n'existe pas
With Sheets("Salarié XX")
    .Visible = xlSheetVisible 'au cas où la feuille serait masquée
    For Each r In Intersect(r.EntireRow, [A:B]).Rows 'si entrées multiples (copier-coller)
        If r.Cells(1) <> "" And r.Cells(2) <> "" Then 'il faut le nom et le prénom
            x = r.Cells(1) & " " & r.Cells(2)
            If IsError(Sheets(x)) Then
                .Copy After:=Sheets(Sheets.Count)
                ActiveSheet.Name = x
            End If
        End If
    Next
End With
Me.Activate
End Sub
A+
 

Benoit DESCOURS

XLDnaute Junior
Petit rab...
Comment classer cette feuille par ordre alphabétique sachant que j'ai :
LISTE CHANTIER / FACTURATION / Plein de feuille ici /PERSONNEL / BON Jean / Et ainsi de suite / Salarié XX / Paramètres

Je voudrais voir la feuillée créée positionnée entre PERSONNEL et Salarié XX et classé par ordre alphabétique.

Benoit
 

job75

XLDnaute Barbatruc
Re,
Je voudrais voir la feuillée créée positionnée entre PERSONNEL et Salarié XX et classé par ordre alphabétique.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, x$, i%, j%
Set r = Intersect(Target, Range("A2:B" & Rows.Count), UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next 'si la feuille n'existe pas
With Sheets("Salarié XX")
    .Visible = xlSheetVisible 'au cas où la feuille serait masquée
    For Each r In Intersect(r.EntireRow, [A:B]).Rows 'si entrées multiples (copier-coller)
        If r.Cells(1) <> "" And r.Cells(2) <> "" Then 'il faut le nom et le prénom
            x = r.Cells(1) & " " & r.Cells(2)
            If IsError(Sheets(x)) Then
                .Copy After:=Me
                ActiveSheet.Name = x
            End If
        End If
    Next
    For i = Me.Index + 1 To .Index - 1
        For j = i + 1 To .Index - 1
            If Sheets(j).Name < Sheets(i).Name Then Sheets(j).Move Before:=Sheets(i)
    Next j, i
End With
Me.Activate
End Sub
Au début il faut que la feuille "Salarié XX" soit placée juste après la feuille "PERSONNEL".

A+
 

job75

XLDnaute Barbatruc
Re,
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, x$, i%, j%
Set r = Intersect(Target, Range("A2:B" & Rows.Count), UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next 'si la feuille n'existe pas
With Sheets("Salarié XX")
    If IsError(.Name) Then MsgBox "Créez la feuille 'Salarié XX' !", 48: Exit Sub
    .Visible = xlSheetVisible 'au cas où la feuille serait masquée
    For Each r In Intersect(r.EntireRow, [A:B]).Rows 'si entrées multiples (copier-coller)
        If r.Cells(1) <> "" And r.Cells(2) <> "" Then 'il faut le nom et le prénom
            x = r.Cells(1) & " " & r.Cells(2)
            If IsError(Sheets(x)) Then
                .Copy After:=Me
                ActiveSheet.Name = x
                Me.Hyperlinks.Add r.Cells(1), "", "#'" & x & "'!A1" 'lien hypertexte
            End If
        End If
    Next
    For i = Me.Index + 1 To .Index - 1
        For j = i + 1 To .Index - 1
            If Sheets(j).Name < Sheets(i).Name Then Sheets(j).Move Before:=Sheets(i)
    Next j, i
End With
Me.Activate
End Sub
A+