AJOUTER COMMENTAIRE VIA MACRO EN IMPORTANT DONNEES SUR UNE AUTRE FEUILLE (résolu)

[moutchec]

bonjour à tous.
je cherche une macro pour ajouter un commentaire affiché dans la cellule active en effaçant au passage tout autre commentaire de la feuille.
exemple sur la feuille 1 si la cellule active est A2 = alors deux lignes dans un petit cadre en commentaire pour aller chercher sur la feuille 2 les données A1 et SOL qui correspondent au contenu de A2 de la feuille 1

 

[Hieu]

Salut,

Une idée :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set wf = WorksheetFunction
Set f = Sheets("Feuil2")
If Not Intersect(Target, Range("a2:b6")) Is Nothing Then
Range("a2:b6").ClearComments
t1 = wf.Index(f.Range("b2:b11"), wf.Match(Target, f.Range("a2:a11"), 0))
t2 = wf.Index(f.Range("c2:c11"), wf.Match(Target, f.Range("a2:a11"), 0))
Target.AddComment
Target.Comment.Visible = True
Target.Comment.Text Text:=t1 & Chr(10) & t2
End If
End Sub

 

[moutchec]

bonjour, le code fonctionne mais génère un bug lorsque la cellule est vide par exemple.
l'idéal serait qu'il y ait un commentaire lorsqu'il y a une donnée et pas de commentaire quand la cellule est vide ou que la cellule active est hors du champs.
merci beaucoup.

 

[Hieu]

ajout d'une petite condition:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set wf = WorksheetFunction
Set f = Sheets("Feuil2")
If IsEmpty(Target) Then Exit Sub
If Not Intersect(Target, Range("a2:b6")) Is Nothing Then
Range("a2:b6").ClearComments
t1 = wf.Index(f.Range("b2:b11"), wf.Match(Target, f.Range("a2:a11"), 0))
t2 = wf.Index(f.Range("c2:c11"), wf.Match(Target, f.Range("a2:a11"), 0))
Target.AddComment
Target.Comment.Visible = True
Target.Comment.Text Text:=t1 & Chr(10) & t2
End If
End Sub

 

[moutchec]

ok ça marche!
si possible, une amélioration pour que ce soit parfait : aucun commentaire quand la cellule active est vide ou hors du champs.
actuellement, le commentaire de la dernière cellule valable reste affiché.
sincères remerciements.

 

[Hieu]

Comme ca ??

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set wf = WorksheetFunction
Set f = Sheets("Feuil2")
Range("a2:b6").ClearComments
If IsEmpty(Target) Then Exit Sub
If Not Intersect(Target, Range("a2:b6")) Is Nothing Then
t1 = wf.Index(f.Range("b2:b11"), wf.Match(Target, f.Range("a2:a11"), 0))
t2 = wf.Index(f.Range("c2:c11"), wf.Match(Target, f.Range("a2:a11"), 0))
Target.AddComment
Target.Comment.Visible = True
Target.Comment.Text Text:=t1 & Chr(10) & t2
End If
End Sub

 

[moutchec]

re: voici mon fichier réel en annexe, quelques soucis pour faire fonctionner.
j'ai adapté le code sur la feuille MAGASIN et fait des entrées via l'userform de la feuille menu et au début ça marchait mais après fermeture et ouverture du fichier il affiche un message d'erreur.
il beug également sur les cellules contenant des formules ou numéros d'emplacements par exemple qui n'ont évidemment pas de correspondance dans la feuille STOCKS.
beug aussi s'il y a sélection de plusieurs cellules.
pas aussi simple que je croyais!

 

[moutchec]

ok, le commentaire ne se met pas parce que la feuille est verrouillée au démarrage. code : toto
reste le problème des cellules dont les données ne correspondent à rien sur le feuille stock et les cellules contenant des formules.

 

[Hieu]

Salut,

Essaie ceci:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set wf = WorksheetFunction
Set f = Sheets("STOCKS")
On Error Resume Next
test = wf.Match(Target, f.Range("C4:C1000"), 0)
Range("B4:AL55").ClearComments
If IsEmpty(Target) Or IsEmpty(test) Then Exit Sub
If Not Intersect(Target, Range("B4:AL55")) Is Nothing Then
 t1 = wf.Index(f.Range("B4:B1000"), wf.Match(Target, f.Range("C4:C1000"), 0))
 t2 = wf.Index(f.Range("H4:H1000"), wf.Match(Target, f.Range("C4:C1000"), 0))
 Target.AddComment
 Target.Comment.Visible = True
 Target.Comment.Text Text:=t1 & Chr(10) & t2
End If
End Sub

 

[moutchec]

bonjour, quelques modifs après un détour sur les forums.
grand merci pour ton aide @Hieu, j'y serais pas arrivé tout seul.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set wf = WorksheetFunction
Set f = Sheets("STOCKS")
On Error Resume Next
test = wf.Match(Target, f.Range("C4:C1000"), 0)
Range("B4:AL58").ClearComments
If IsEmpty(Target) Or IsEmpty(test) Then Exit Sub
If Not Intersect(Target, Range("B4:AL58")) Is Nothing Then
t1 = wf.Index(f.Range("B4:B1000"), wf.Match(Target, f.Range("C4:C1000"), 0))
t2 = "Quantité" & " " & ":" & " " & wf.Index(f.Range("H4:H1000"), wf.Match(Target, f.Range("C4:C1000"), 0))
Sheets("MAGASINS").Unprotect
Target.AddComment
Target.Comment.Visible = True
Target.Comment.Shape.TextFrame.AutoSize = True
Target.Comment.Text Text:=t1 & Chr(10) & t2
End If
End Sub

 

[Hieu]

Pour t2, tu peux écrire ainsi:

t2 = "Quantité : " & wf.Index(f.Range("H4:H1000"), wf.Match(Target, f.Range("C4:C1000"), 0))

 

[moutchec]

bonjour, ça fonctionne! merci.
je vous soumet une autre demande s'il vous est possible de m'aider.
je souhaiterais apporter une modif sur le code de l'userform1 du fichier en annexe (poste 7). il s'agit de faire en sorte que pour chaque lot il puisse y avoir deux emplacements possibles, cela impliquera sans doute une modif de l'userform1 pour proposer les deux emplacements en "entrée" et en "sortie" et laisser le choix de "sortie " de l'un ou l'autre ou les deux, et la même possibilité pour les transferts . mais honnêtement je sais pas si c'est réalisable ou pas.
merci.

 

[Hieu]

Salut,
Je n'ai pas trop compris ta demande, et j'suis pas très à l'aise, avec les userform. Je te propose d'ouvrir un nouveau post. Ta requete est réalisable ; quelqu'un d'aure trouvera la solution !

 

[moutchec]

Bsr OK sincères remerciements pour votre aide. Merci.

 

[Hieu]

Salut Moutchec,

Je ne suis pas très à l'aise avec les userform ;
Peut-etre, en faisant un fichier "light" avec uniquement ton probleme, tu auras plus de reponses ?