effacer et créer commentaire sur double clic

[pascal21]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 If Target.Comment Is Nothing Then
    Target.AddComment
    Target.Comment.Text Text:=CStr(Now) & Chr(10) & Environ("PASCAL") & Chr(10)
    lg = Len(Target.Comment.Text)
    With Target.Comment.Shape.TextFrame
      .Characters(Start:=1, Length:=lg).Font.Name = "Verdana"
      .Characters(Start:=1, Length:=lg).Font.Size = 8
      .Characters(Start:=1, Length:=lg).Font.Bold = True
      .Characters(Start:=1, Length:=lg).Font.Italic = True
      .Characters(Start:=1, Length:=lg).Font.ColorIndex = 3
      .Characters(Start:=lg, Length:=99).Font.Bold = False
      .Characters(Start:=lg, Length:=99).Font.Italic = False
      .Characters(Start:=lg, Length:=99).Font.ColorIndex = 1
    End With
    SendKeys "m"
  Else
    SendKeys "m"
  End If
End Sub

bonsoir le forum
ce code de boisgontier (merci à lui) permet de créer un commentaire avec la date du jour dans une cellule
je cherche le moyen si il y a déjà un commentaire en place dans une cellule que le double clic mette à jour le commentaire
ou, en gros que le double clic efface l'ancien commentaire et soit remplacé par un nouveau avec la date du jour
merci

 

[Roland_M]

Re : effacer et créer commentaire sur double clic

bonsoir

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Retour:
 If Target.Comment Is Nothing Then
    Target.AddComment
    Target.Comment.Text Text:=CStr(Now) & Chr(10) & Environ("PASCAL") & Chr(10)
    lg = Len(Target.Comment.Text)
    With Target.Comment.Shape.TextFrame
      .Characters(Start:=1, Length:=lg).Font.Name = "Verdana"
      .Characters(Start:=1, Length:=lg).Font.Size = 8
      .Characters(Start:=1, Length:=lg).Font.Bold = True
      .Characters(Start:=1, Length:=lg).Font.Italic = True
      .Characters(Start:=1, Length:=lg).Font.ColorIndex = 3
      .Characters(Start:=lg, Length:=99).Font.Bold = False
      .Characters(Start:=lg, Length:=99).Font.Italic = False
      .Characters(Start:=lg, Length:=99).Font.ColorIndex = 1
    End With
    SendKeys "m"
 Else
    Target.ClearComments: GoTo Retour
    SendKeys "m"
 End If
End Sub