XL 2019 insérer un commentaire selon la valeur de la cellule

[oukthr]

Bonjour, comme exprimé dans le titre, j'aimerai bien une aide pour inserer un commentaire automatiquement selon la valeur de la cellule,
par exemple, j'ai un tableau avec des références correspondants à des désignation, j'aimerai que quand je met la référence dans une cellule, un commentaire contenant la désignation correspondante s'insère dans cette cellule, comme dans la feuille cal, cellules B2 et C2 dans le fichier joint.
Merci d'avance.

 

[mapomme]

Bonsoir @oukthr ,

Une solution par VBA.
Le commentaire se met à jour ou s'efface quand on modifie ou efface un user.
Le code est dans le module de la feuille"Cal".

Private Sub Worksheet_Change(ByVal Target As Range)
Dim TS As ListObject, plage As Range, xrgRef As Range, x As Range, n

   Set xrgRef = Sheets("liste").Range("a1").ListObject.DataBodyRange
   With Range("a1").ListObject
      Set plage = .DataBodyRange.Offset(, 1).Resize(, .ListColumns.Count - 1)
      On Error Resume Next
      For Each x In Intersect(plage, Target)
         x.Comment.Delete
         If x <> "" Then
            n = Application.Match(x, xrgRef.Columns(1), 0)
            If Not IsError(n) Then
               x.AddComment
               x.Comment.Text Text:=xrgRef(n, 2)
            End If
         End If
      Next x
   End With
End Sub

 

[oukthr]

Bonjour, tout d'abord merci, votre code insère bien un commentaire mais qui est par contre vide.

 

[mapomme]

Re,

Je crois bien que je n'ai pas fourni la bonne version.
Essayez celle qui est jointe à ce message.

 

[oukthr]

Merci beaucoup, ça marche comme je veux,
encore merci.

 

[oukthr]

Bonjour, désolé pour le dérangement, je pense avoir un problème, quand j'ai activer les partage du classeur, j'étais obligé de convertir les tableaux en plages normales, ce qui a pour effet que votre code ne marche plus.

 

[TooFatBoy]

Bonjour,

Une proposition en pièce jointe, en attendant le retour du camarade à la magnifique pomme bleue.

 

[mapomme]

Bonjour @oukthr, @TooFatBoy ,

Voici la v3 sans tableau structuré :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim TS As ListObject, plage As Range, xrgRef As Range, x, n
 
   With Sheets("liste")
      If .FilterMode Then .ShowAllData
      Set xrgRef = .Range("a1").CurrentRegion.Columns("a:b"): End With
   With Sheets("Cal")
      n = .Range("a1").End(xlToRight).Column
      Set plage = .Range("a1").CurrentRegion.Offset(, 1).Resize(, n - 1)
      On Error Resume Next
      For Each x In Intersect(plage, Target)
         x.Comment.Delete
         If x <> "" Then
            n = Application.Match(x, xrgRef.Columns(1), 0)
            If Not IsError(n) Then
               x.AddComment
               x.Comment.Text Text:=xrgRef.Cells(n, 2).Value
            End If
         End If
      Next x
   End With
End Sub

 

[oukthr]

Bonjour,

Une proposition en pièce jointe, en attendant le retour du camarade à la magnifique pomme bleue.

Bonjour @oukthr, @TooFatBoy ,

Voici la v3 sans tableau structuré :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim TS As ListObject, plage As Range, xrgRef As Range, x, n
 
   With Sheets("liste")
      If .FilterMode Then .ShowAllData
      Set xrgRef = .Range("a1").CurrentRegion.Columns("a:b"): End With
   With Sheets("Cal")
      n = .Range("a1").End(xlToRight).Column
      Set plage = .Range("a1").CurrentRegion.Offset(, 1).Resize(, n - 1)
      On Error Resume Next
      For Each x In Intersect(plage, Target)
         x.Comment.Delete
         If x <> "" Then
            n = Application.Match(x, xrgRef.Columns(1), 0)
            If Not IsError(n) Then
               x.AddComment
               x.Comment.Text Text:=xrgRef.Cells(n, 2).Value
            End If
         End If
      Next x
   End With
End Sub

Bonjour, merci a tout les deux, les 2 codes me donnent le résultat que je cherchais, encore merci et bonne journée.