XL 2016 créer un onglet automatiquement suite

[bobafric]

Bonjour à tous ci-dessous la solution que vous m'avez donnée précédemment

sur une feuille Excel je voudrai créer un onglet en tapant le nom sur une cellule de la feuille 1
Exemple feuil1 cellule A1 je tape nom pour créer automatiquement un onglet nom
feuil1 cellule A2 je tape prénom pour onglet prénom


Ce code à placer dans le module de la feuille où vous écrivez les noms :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 1 Or Target.Count > 1 Then Exit Sub
Dim nom$
nom = Left(CStr(Target), 31)
If nom = "" Then Exit Sub
On Error Resume Next
Sheets(nom).Activate
If Err = 0 Then Exit Sub
Err = 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = nom
If Err Then
ActiveSheet.Delete
Me.Activate
Target.Select
Application.ScreenUpdating = False
MsgBox "Il y a des caractères interdits dans le nom !", 48
End If
End Sub

Peut on dans ce code faire en sorte que lorsque on tape un nom dans une cellule, créer directement le lien avec la feuille correspondante pour éviter de créer ce lien ligne après ligne car il va y avoir beaucoup de noms et de feuilles.
Je joins un fichier pour exemple avec le code précédent
Merci pour votre aide

 

[Dan]

Bonjour,

Bien que je ne suis pas un adepte des liens hypertextes, dans votre code juste au dessus de la ligne If Err Then, ajoutez cette ligne

Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:=nom & "!L1C1", TextToDisplay:=nom

Cordialement

 

[bobafric]

Bonjour,

Bien que je ne suis pas un adepte des liens hypertextes, dans votre code juste au dessus de la ligne If Err Then, ajoutez cette ligne

Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:=nom & "!L1C1", TextToDisplay:=nom

Cordialement

Merci Dan peut être pas adepte mais rapide et efficace
Quel plaisir Excel Download

 

[fanch55]

Bonjour, pour le fun

• 1ère lettre en majuscule
• tri des onglets
• tri de la colonne de saisie

(A ce propos, renommer la feuille noms en $noms
--> pour être toujours en début des onglets et éviter de la rechercher au milieu de tous les prénoms )

Nota: pour les hyperliens vers une feuille, toujours la mettre entre simples cotes sinon le code ne va pas aimer les caractères spéciaux mais autorisés :
Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:="'" & Target & "'!L1C1"

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case True
        Case Target.Column > 1:     'rien
        Case Target.Count > 1:      'rien
        Case IsEmpty(Target):       'rien
        Case Else
            On Error Resume Next
            Application.EnableEvents = False ' On va "retravailler" Target
            Target = StrConv(Target, vbProperCase)
            With Sheets.Add
                .Name = Target
                If Err = 0 Then
                    SortSheetsTabName
                    Target.Parent.Activate
                    Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:="'" & Target & "'!L1C1"
                    With Sort
                        .SortFields.Clear
                        .SortFields.Add Key:=Columns(Target.Column).Cells(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .SetRange Columns(Target.Column)
                        .Header = xlNo: .MatchCase = False
                        .Orientation = xlTopToBottom:   .SortMethod = xlPinYin
                        .Apply
                    End With
                    Columns(Target.Column).Find(.Name).Select
                Else
                    Application.DisplayAlerts = False: .Delete
                    Target.Select
                        MsgBox Err.Description, vbCritical
                    Target.ClearContents
                End If
            End With
            Application.EnableEvents = True
    End Select
End Sub
Sub SortSheetsTabName() ' Microsoft docs pour trier les onglets
    Application.ScreenUpdating = False
    Dim iSheets%, i%, j%
    iSheets = Sheets.Count
    For i = 1 To iSheets - 1
        For j = i + 1 To iSheets
            If LCase(Sheets(j).Name) < LCase(Sheets(i).Name) Then
                Sheets(j).Move before:=Sheets(i)
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

 

[bobafric]

Bonjour, pour le fun

• 1ère lettre en majuscule
• tri des onglets
• tri de la colonne de saisie

(A ce propos, renommer la feuille noms en $noms
--> pour être toujours en début des onglets et éviter de la rechercher au milieu de tous les prénoms )

Nota: pour les hyperliens vers une feuille, toujours la mettre entre simples cotes sinon le code ne va pas aimer les caractères spéciaux mais autorisés :
Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:="'" & Target & "'!L1C1"

Private Sub Worksheet_Change(ByVal Target As Range)
    Select Case True
        Case Target.Column > 1:     'rien
        Case Target.Count > 1:      'rien
        Case IsEmpty(Target):       'rien
        Case Else
            On Error Resume Next
            Application.EnableEvents = False ' On va "retravailler" Target
            Target = StrConv(Target, vbProperCase)
            With Sheets.Add
                .Name = Target
                If Err = 0 Then
                    SortSheetsTabName
                    Target.Parent.Activate
                    Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:="'" & Target & "'!L1C1"
                    With Sort
                        .SortFields.Clear
                        .SortFields.Add Key:=Columns(Target.Column).Cells(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .SetRange Columns(Target.Column)
                        .Header = xlNo: .MatchCase = False
                        .Orientation = xlTopToBottom:   .SortMethod = xlPinYin
                        .Apply
                    End With
                    Columns(Target.Column).Find(.Name).Select
                Else
                    Application.DisplayAlerts = False: .Delete
                    Target.Select
                        MsgBox Err.Description, vbCritical
                    Target.ClearContents
                End If
            End With
            Application.EnableEvents = True
    End Select
End Sub
Sub SortSheetsTabName() ' Microsoft docs pour trier les onglets
    Application.ScreenUpdating = False
    Dim iSheets%, i%, j%
    iSheets = Sheets.Count
    For i = 1 To iSheets - 1
        For j = i + 1 To iSheets
            If LCase(Sheets(j).Name) < LCase(Sheets(i).Name) Then
                Sheets(j).Move before:=Sheets(i)
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

Merci fanch et merci à tous, vous êtes des pros
J'ai terminé mon appli nickel
A plus et merci encore