Info bulle ( mise a jour & ajustement du texte) automatiquement

Private Sub Worksheet_Activate()
Commentaire [A:A]
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Commentaire Target
End Sub

Sub Commentaire(r As Range)
Set r = Intersect(r, Range("A3:A" & Rows.Count), r.Parent.UsedRange)
If r Is Nothing Then Exit Sub
Dim f$, c As Range
For Each r In r
  r.ClearComments 'RAZ
  f = Replace(r.Formula, ")", "")
  f = Mid(f, InStrRev(f, ",") + 1)
  If TypeName(Evaluate(f)) = "Range" Then
    Set c = Evaluate(f)
    If c(1, 2) <> "" Then
      With r.AddComment(c(1, 2).Value).Shape
        .TextFrame.AutoSize = True 'ajustement automatique
        If .Width > 300 Then
          .Height = .Width * .Height / 200 * 1.1
          .Width = 200
        End If
      End With
    End If
  End If
Next
End Sub

Private Sub Worksheet_Activate()
Commentaire [A:A,F:F], Range("A3:A" & Rows.Count & ",F3:F" & Rows.Count)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Commentaire Target, Range("A3:A" & Rows.Count & ",F3:F" & Rows.Count)
End Sub

Sub Commentaire(r As Range, plage As Range)
Set r = Intersect(r, plage, r.Parent.UsedRange)
If r Is Nothing Then Exit Sub
Dim f$, c As Range
For Each r In r
  r.ClearComments 'RAZ
  f = Replace(r.Formula, ")", "")
  f = Mid(f, InStrRev(f, ",") + 1)
  If TypeName(Evaluate(f)) = "Range" Then
    Set c = Evaluate(f)
    If c(1, 2) <> "" Then
      With r.AddComment(c(1, 2).Value).Shape
        .TextFrame.AutoSize = True 'ajustement automatique
        If .Width > 300 Then
          .Height = .Width * .Height / 200 * 1.1
          .Width = 200
        End If
      End With
    End If
  End If
Next
End Sub

Private Sub Worksheet_Activate()
ActiveSheet.Unprotect ""
Commentaire [B:B,H:H], Range("B3:B" & Rows.Count & ",H3:H" & Rows.Count)
ActiveSheet.Protect ""
End Sub