Nommer cellule en fonction d'une autre

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
  With r(1, 6) 'cellule en colonne F
    If r = "" Then
      .ClearComments
      .Name.Delete
    Else
      x = ""
      x = .Name.Name 'si la cellule est déjà nommée
      t = x
1     t = InputBox("Entrez le pseudo de <" & r & "> :", "Nommer la cellule " & .Address(0, 0), t)
      If t <> "" Then
        .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
        .Name = t 'nouveau nom
        If .Name.Name <> t Then GoTo 1
        .AddComment: .Comment.Text t: .Comment.Shape.TextFrame.AutoSize = True
        '.Comment.Visible = True 'si l'on veut afficher le commentaire
      End If
      If IsError(.Name) Then If x <> "" Then .Name = x 'l'ancien nom est recréé
    End If
  End With
Next r
End Sub