Cmt répéter un événement avec de nvlles entrées

Le 12/04/2019 à 16:28

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

Le 12/04/2019 à 17:18

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
Le 12/04/2019 à 18:28

Merci i20100,

Je vais essayer l'astuce et voir si ça fonctionne. Je reviens vers vous ensuite.

Le 12/04/2019 à 20:47

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

i20100 a écrit :

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
Le 12/04/2019 à 21:54

re,

peux-tu joindre ton fichier ?

Le 12/04/2019 à 22:15

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

3sequential-diagram-test.zip (42.71 Ko)
Le 12/04/2019 à 22:55

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
Le 13/04/2019 à 10:23

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.

i20100 a écrit :

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
Le 13/04/2019 à 15:04

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 ?

3pijenyal-sequential-diagram-test.zip (71.98 Ko)
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
Le 14/04/2019 à 01:26

Excuse-moi du retard. J'étais out. Je viens de voir ta proposition que je vais m'atteler à exploiter. Merci bcp. Je reviens ensuite...

Le 14/04/2019 à 01:54

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.

i20100 a écrit :

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
Le 14/04/2019 à 02:04

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

Le 14/04/2019 à 15:56

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
Le 14/04/2019 à 19:11

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.

3pijenyal-test-3.zip (74.04 Ko)
i20100 a écrit :

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
Le 14/04/2019 à 19:23

re,

à voir,

2pijenyal-test-3.zip (71.14 Ko)

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
Le 14/04/2019 à 19:27

Et un 3ème forum.

C'est bon, je laisse tomber...

Le 14/04/2019 à 19:39

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.

eriiic a écrit :

Et un 3ème forum.

C'est bon, je laisse tomber...

Le 14/04/2019 à 19:41

re,

nouvelle version avec gestion des 0

5pijenyal-test-4.zip (71.27 Ko)
Le 14/04/2019 à 19:57

Celle-ci marche mieux, à part pour la valeur 0 sur "EPA", je ne sais pq. Je vais analyser ça.

Je vais l'exploiter et l'adopter sur un mon fichier complet.

Je ne sais pas cmt te remercier pour ces précieux dépannage ...

i20100 a écrit :

re,

nouvelle version avec gestion des 0

pijenyal_test_4.xls

Le 19/04/2019 à 20:49

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

Rechercher des sujets similaires à "cmt repeter evenement nvlles entrees"