Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim r As Range
Set r = Intersect(Target, Range("A6", Range("A" & Rows.Count)))
If Not r Is Nothing Then If r <> "" Then Cancel = True: Worksheet_Change r
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, x$, t$, nom As Name
Set r = Intersect(Target, Range("A6", Range("A" & Rows.Count)), Me.UsedRange)
If r Is Nothing Then Exit Sub
On Error Resume Next
For Each r In r 'si entrées multiples
If r = "" Then
r(1, 6).Interior.ColorIndex = xlNone
r(1, 6).Name.Delete
Else
x = ""
x = r(1, 6).Name.Name 'si la cellule est déjà nommée
t = x
1 t = InputBox("Entrez le pseudo de <" & r & "> :", "Nommer la cellule " & r(1, 6).Address(0, 0), t)
If t <> "" Then
r(1, 6).Name.Delete 'suppression de l'ancien nom
For Each nom In ThisWorkbook.Names
If LCase(t) = LCase(nom.Name) Then _
MsgBox "Ce pseudo est déjà utilisé !", 48: GoTo 1
Next nom
r(1, 6).Name = t 'nouveau nom
If r(1, 6).Name.Name <> t Then GoTo 1
r(1, 6).Interior.ColorIndex = 6 'couleur jaune
End If
If IsError(r(1, 6).Name) Then If x <> "" Then r(1, 6).Name = x 'l'ancien nom est recréé
End If
Next r
End Sub