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

oukthr · 10 Novembre 2022

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 · 11 Novembre 2022

Bonjour @oukthr, @TooFatBoy ,

Voici la v3 sans tableau structuré :

VB:

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...

mapomme · 10 Novembre 2022

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".

VB:

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 · 10 Novembre 2022

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

mapomme · 10 Novembre 2022

Re,

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

oukthr · 11 Novembre 2022

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

oukthr · 11 Novembre 2022

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 · 11 Novembre 2022

Bonjour,

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

mapomme · 11 Novembre 2022

Bonjour @oukthr, @TooFatBoy ,

Voici la v3 sans tableau structuré :

VB:

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 · 11 Novembre 2022

TooFatBoy à dit:
Bonjour,

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

mapomme à dit:

Bonjour @oukthr, @TooFatBoy ,

Voici la v3 sans tableau structuré :

VB:

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.

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

oukthr

XLDnaute Nouveau

Pièces jointes

mapomme

mapomme

XLDnaute Barbatruc

Pièces jointes

oukthr

XLDnaute Nouveau

mapomme

XLDnaute Barbatruc

Pièces jointes

oukthr

XLDnaute Nouveau

oukthr

XLDnaute Nouveau

TooFatBoy

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

oukthr

XLDnaute Nouveau

Discussions similaires