Cmt répéter un événement avec de nvlles entrées
Bjr,
Je souhaite incrémenter une suite d'instruction en copiant-collant une première qui fonctionne bien.
Le code consiste à affecter à chaque objet (forme) une couleur en fonction de valeurs saisies dans une cellule.
Les instructions se présentent comme suit :
Private Sub Worksheet_Change(ByVal Target As Range)
'Updateby Extendoffice 20160704
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) Then
If Target.Value >= 100 Then
ActiveSheet.Shapes("Shape 1").Fill.ForeColor.RGB = RGB(255, 192, 0)
Else
ActiveSheet.Shapes("Shape 1").Fill.ForeColor.RGB = RGB(230, 230, 230)
End If
End If
End Sub
Sauf que qd je fais un copier-coller sous cette instruction en prenant soin de changer "A1" en "A2" et "Shape 1" en "Shape 2" et d'enléver End Sub, ça ne marche pas. J'ai dû louper un détail ou je ne fais pas correctement bien les choses.
Qlq1 pour m'aider svp ! Merci par avance
Bonjour
voici un exemple pour les cellules "A1:A10"
Private Sub Worksheet_Change(ByVal Target As Range)
'Updateby Extendoffice 20160704
If Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) Then
If Target.Value >= 100 Then
ActiveSheet.Shapes(Target.Row).Fill.ForeColor.RGB = RGB(255, 192, 0)
Else
ActiveSheet.Shapes(Target.Row).Fill.ForeColor.RGB = RGB(230, 230, 230)
End If
End If
End Sub
Merci i20100,
Je vais essayer l'astuce et voir si ça fonctionne. Je reviens vers vous ensuite.
Re,
Je suis un novice en VBA.
Votre formule est correcte mais il me manque un élément important. Je dois corréler "A1" à "Shape 1", "A2" à "Shape 2"... En appliquant les conditions données.
Si vous avez une idée, je suis preneur.
Merci par avance
Bonjour
voici un exemple pour les cellules "A1:A10"
Private Sub Worksheet_Change(ByVal Target As Range) 'Updateby Extendoffice 20160704 If Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub If IsNumeric(Target.Value) Then If Target.Value >= 100 Then ActiveSheet.Shapes(Target.Row).Fill.ForeColor.RGB = RGB(255, 192, 0) Else ActiveSheet.Shapes(Target.Row).Fill.ForeColor.RGB = RGB(230, 230, 230) End If End If End Sub
re,
peux-tu joindre ton fichier ?
Oui, bien sûr.
Les shapes sont nommées : "ARA" , "EPA" et "DHA".
ça fonctionne pour "ARA" mais je veux faire pareil pour "EPA" puis "DHA". Les couleurs des formes doivent changer en fonction des valeurs que je vais entrer dans les cellules E9:E11
re,
à tester,
Private Sub Worksheet_Change(ByVal Target As Range)
'Updateby Extendoffice 20160704
If Intersect(Target, Range("E9:E11")) Is Nothing Then Exit Sub
Select Case Target.Row
Case 9: Set sh = ActiveSheet.Shapes("ARA")
Case 10: Set sh = ActiveSheet.Shapes("DHA")
Case 11: Set sh = ActiveSheet.Shapes("EPA")
End Select
If IsNumeric(Target.Value) Then
If Target.Value >= 50000 Then
sh.Fill.ForeColor.RGB = RGB(255, 192, 0)
ElseIf Target.Value < 50000 And Target.Value >= 5000 Then
sh.Fill.ForeColor.RGB = RGB(251, 221, 41)
ElseIf Target.Value < 5000 And Target.Value >= 500 Then
sh.Fill.ForeColor.RGB = RGB(255, 255, 0)
ElseIf Target.Value < 500 And Target.Value >= 50 Then
sh.Fill.ForeColor.RGB = RGB(255, 255, 153)
ElseIf Target.Value < 5 And Target.Value >= 1 Then
sh.Fill.ForeColor.RGB = RGB(255, 255, 204)
Else
sh.Fill.ForeColor.RGB = RGB(230, 230, 230)
End If
End If
End Sub
Merci beaucoup. ça marche très bien. J'ai pu l'adapter pour ajouter des formes. Merci encore.
Si tu as une astuce pour affecter à chaque forme (shape) une condition unique (par ex. target value >5000 pour "shape 1" et target value > 100 pour "shape 2"), je suis preneur. L'idée étant de définir des limites de valeurs différentes pour chaque cas.
Merci encore !
Cdt.
re,
à tester,
Private Sub Worksheet_Change(ByVal Target As Range) 'Updateby Extendoffice 20160704 If Intersect(Target, Range("E9:E11")) Is Nothing Then Exit Sub Select Case Target.Row Case 9: Set sh = ActiveSheet.Shapes("ARA") Case 10: Set sh = ActiveSheet.Shapes("DHA") Case 11: Set sh = ActiveSheet.Shapes("EPA") End Select If IsNumeric(Target.Value) Then If Target.Value >= 50000 Then sh.Fill.ForeColor.RGB = RGB(255, 192, 0) ElseIf Target.Value < 50000 And Target.Value >= 5000 Then sh.Fill.ForeColor.RGB = RGB(251, 221, 41) ElseIf Target.Value < 5000 And Target.Value >= 500 Then sh.Fill.ForeColor.RGB = RGB(255, 255, 0) ElseIf Target.Value < 500 And Target.Value >= 50 Then sh.Fill.ForeColor.RGB = RGB(255, 255, 153) ElseIf Target.Value < 5 And Target.Value >= 1 Then sh.Fill.ForeColor.RGB = RGB(255, 255, 204) Else sh.Fill.ForeColor.RGB = RGB(230, 230, 230) End If End If End Sub
Bonjour,
je l'ai refait avec des plages nommées, (voir sur Feuil2)
"dose", "condition" et "_rgb"
j'ai du inverser le tableau,
dit-moi si ça convient ?
Private Sub Worksheet_Change(ByVal Target As Range)
'Updateby Extendoffice 20160704
If Intersect(Target, Range("dose")) Is Nothing Then Exit Sub
Set sh = ActiveSheet.Shapes(Target.Offset(0, -2))
n = Application.Match(Target, Range("dose"), 0)
couleur = Application.Index(Range("_rgb"), Application.Match(Target, Range("condition").Rows(n)))
cl = Split(couleur, ",")
sh.Fill.ForeColor.RGB = RGB(cl(0), cl(1), cl(2))
End Sub
Excuse-moi du retard. J'étais out. Je viens de voir ta proposition que je vais m'atteler à exploiter. Merci bcp. Je reviens ensuite...
C'est excellent ! ça marche très bien. Je n'ai pas encore compris tous liens, je pense que je vais l'exploiter pour décliner les arguments et conditions. Pour l'heure, j'ai gardé la précédente solution (avec une seule série de doses pour l'ensemble des formes) qui marche à merveille ! Merci infiniment !
Cependant, je suis buté à l'automatisation de l'exécution de la macro qui ne marche qu'en entrant les valeurs dans les cellules manuellement. Je mets l'explication dans le post suivant.
Bonjour,
je l'ai refait avec des plages nommées, (voir sur Feuil2)
"dose", "condition" et "_rgb"
j'ai du inverser le tableau,
dit-moi si ça convient ?
pijenyal-Sequential diagram_test.xls
Private Sub Worksheet_Change(ByVal Target As Range) 'Updateby Extendoffice 20160704 If Intersect(Target, Range("dose")) Is Nothing Then Exit Sub Set sh = ActiveSheet.Shapes(Target.Offset(0, -2)) n = Application.Match(Target, Range("dose"), 0) couleur = Application.Index(Range("_rgb"), Application.Match(Target, Range("condition").Rows(n))) cl = Split(couleur, ",") sh.Fill.ForeColor.RGB = RGB(cl(0), cl(1), cl(2)) End Sub
Bonjour i20100 ,
J'aimerais exécuter la macro automatiquement lorsque la valeur d'une cellule change.
Le problème est que la cellule contient une formule et ma macro ne fonctionne pas (sauf si je change moi même la valeur, ce que je ne souhaite pas)
Pour rappel, le code consiste à changer la couleur (RGB) de la forme (= objets dessins dénommés "ARA", "EPA" et "DHA") en fonction des valeurs entrées dans les cellules E20; E21, et E22. Sauf que ces valeurs sont issues d'une formule (E20=SI(ESTERREUR(M4);0;M4) par exemple).
Private Sub Worksheet_Change(ByVal Target As Range)
'Updateby Extendoffice 20160704
If Intersect(Target, Range("E20:E22")) Is Nothing Then Exit Sub
Select Case Target.Row
Case 20: Set sh = ActiveSheet.Shapes("ARA")
Case 21: Set sh = ActiveSheet.Shapes("EPA")
Case 22: Set sh = ActiveSheet.Shapes("DHA")
End Select
If IsNumeric(Target.Value) Then
If Target.Value >= 50000 Then
sh.Fill.ForeColor.RGB = RGB(255, 192, 0)
ElseIf Target.Value < 50000 And Target.Value >= 5000 Then
sh.Fill.ForeColor.RGB = RGB(251, 221, 41)
Else
sh.Fill.ForeColor.RGB = RGB(230, 230, 230)
End If
End If
End Sub
Bonjour,
tu pourrais remplacer la macro Worksheet_Change
par celle-ci
Private Sub Worksheet_Calculate()
For i = 9 To Cells(Rows.Count, "C").End(xlUp).Row 'à adapter
Set sh = ActiveSheet.Shapes(Cells(i, "C").Value)
couleur = Application.Index(Range("G4:L4"), Application.Match(Cells(i, "E").Value, Range("G" & i & ":L" & i)))
cl = Split(couleur, ",")
sh.Fill.ForeColor.RGB = RGB(cl(0), cl(1), cl(2))
Next i
End Sub
Merci Eriiic,
Si j'ai bien compris, le remplacement est à faire sur le dernier fichier que tu m'as envoyé? Je dois adapter les cellules de la colonne "C" ?
J'ai fait un essai mais j'ai un message d'erreur comme sur ce fichier joint.
Bonjour,
tu pourrais remplacer la macro
Worksheet_Change
par celle-ciPrivate Sub Worksheet_Calculate() For i = 9 To Cells(Rows.Count, "C").End(xlUp).Row 'à adapter Set sh = ActiveSheet.Shapes(Cells(i, "C").Value) couleur = Application.Index(Range("G4:L4"), Application.Match(Cells(i, "E").Value, Range("G" & i & ":L" & i))) cl = Split(couleur, ",") sh.Fill.ForeColor.RGB = RGB(cl(0), cl(1), cl(2)) Next i End Sub
re,
à voir,
ps/
si la plage des Precursors est fixe, tu pourrais modifier la ligne
For i = 9 To Cells(Rows.Count, "C").End(xlUp).Row
par
For i = 9 To 11
Et un 3ème forum.
C'est bon, je laisse tomber...
Je suis désolé. Je me rends compte que ce n'est pas apprécié de multiplié les forums pour une question. Je l'ai fait par souci d'urgence en espérant avoir une réponse rapidement. Puisque ça pose problème, je vais supprimer mes demandes ailleurs surtout que j'ai bien été aidé par tes interventions.
Encore désolé. Je ne suis pas un forumeur courant et je comprends que cela peut être frustrant pour celui qui aide.
Et un 3ème forum.
C'est bon, je laisse tomber...
Bonjour,
Je tenais à vous dire sincèrement merci pour votre aide sur la macro. J'ai utilisé votre dernière suggestion comme base pour construire un ensemble d'instruction qui fonctionne super bien. Je me suis dit que vous devriez être un génie de la programmation.
Encore désolé d'avoir multiplié les forums sur cette question alors que vous y travailliez déjà. Je n'aurais pas dû.