XL 2010 Modifier une forme selon la valeur d'une cellule - VBA

[MistereVBA]

Bonjour,

Je suis débutante en VBA (novice même) et malgré mes nombreuses tentatives grâce à l'aide de vos discussion, je ne parviens toujours pas à réaliser ce que je souhaite. Pouvez-vous m’aider ?

Mise en situation :
Nous sommes dans une entreprise et il y eu des accidents du travail.
Je souhaite que mon bonhomme change de couleurs lorsque les pourcentages du tableau varient.

Exemple :
Le pourcentage pour les « Doigts et mains » est de 25%, les formes « Main_G » et « Main_D » devraient être en rouge.

J’attends avec impatience une aide de votre part.

MERCI d’avance !

PS : ce fichier sera réalisé sur Excel2016 par la suite.

 

[Hieu]

Salut,

Voilà un essai pour la tête :

Sub mlk()
Set tete = Sheets("Feuil1").Shapes.Range(Array("Tete")).Fill.ForeColor
Select Case Range("c3")
Case Is < 0.1: tete.RGB = RGB(255, 204, 204)
Case Is < 0.2: tete.RGB = RGB(247, 150, 70)
Case Is >= 0.2: tete.RGB = RGB(255, 0, 0)
End Select
End Sub

 

[job75]

Bonsoir MistereVBA, Hieu,

Voyez le fichier joint et cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim pct, coul
pct = Array(0, 0.1, 0.2)
coul = Array(Shapes("Oval 216").Fill.ForeColor, Shapes("Oval 217").Fill.ForeColor, Shapes("Oval 218").Fill.ForeColor)
Shapes("Tete").Fill.ForeColor = coul(Application.Match([C3], pct) - 1)
Shapes("Bras_D").Fill.ForeColor = coul(Application.Match([C4], pct) - 1)
Shapes("Bras_G").Fill.ForeColor = coul(Application.Match([C4], pct) - 1)
Shapes("Torse").Fill.ForeColor = coul(Application.Match([C5], pct) - 1)
Shapes("Dos").Fill.ForeColor = coul(Application.Match([C6], pct) - 1)
Shapes("Main_D").Fill.ForeColor = coul(Application.Match([C7], pct) - 1)
Shapes("Main_G").Fill.ForeColor = coul(Application.Match([C7], pct) - 1)
Shapes("Jambe_D").Fill.ForeColor = coul(Application.Match([C8], pct) - 1)
Shapes("Jambe_G").Fill.ForeColor = coul(Application.Match([C8], pct) - 1)
Shapes("Pied_D").Fill.ForeColor = coul(Application.Match([C8], pct) - 1)
Shapes("Pied_G").Fill.ForeColor = coul(Application.Match([C8], pct) - 1)
Shapes("Cuir").Fill.ForeColor = coul(Application.Match([C9], pct) - 1)
End Sub

à placer dans le code de la feuille (clic droit sur l'onglet et Visualiser le code).

Edit : par sécurité j'ai mis une validation des données sur la plage C3:C10.

A+

 

[job75]

Re,

Avec 2 tableaux de plus et une boucle la macro est un peu plus simple :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim pct, coul, s, lig, i%
pct = Array(0, 0.1, 0.2)
coul = Array(Shapes("Oval 216").Fill.ForeColor, Shapes("Oval 217").Fill.ForeColor, Shapes("Oval 218").Fill.ForeColor)
s = Split("Tete Bras_D Bras_G Torse Dos Main_D Main_G Jambe_D Jambe_G Pied_D Pied_G Cuir")
lig = Split("3 4 4 5 6 7 7 8 8 8 8 9")
For i = 0 To UBound(s)
    Shapes(s(i)).Fill.ForeColor = coul(Application.Match(Range("C" & lig(i)), pct) - 1)
Next
End Sub

Fichier (2).

Bonne nuit.

 

[MistereVBA]

Bonjour à tous,

Merci beaucoup pour vos réponses !
Un ami m'a aidé à réalisé la macro tout fonctionne (cf.: Excercice Test)

J'ai maintenant un autre problème : je souhaite copier la macro de "Exercice Test" dans mon fichier original (cf: Analyse accident).
Jusqu’à la tout vas bien, il me suffit de changer le nom des cellules.

Cependant, la VBA ne fonctionne pas dans mon nouveau fichier "Analyse Accident"...
Est-ce parce que la valeur de la cellule est la somme d'une formule ?
Comment faire ?

Merci d'avance !

 

[job75]

Bonjour le forum,

Un ami m'a aidé à réalisé la macro tout fonctionne (cf.: Excercice Test)

Vous ne manquez pas de souffle MistereVBA !!! Pourquoi venir sur ce forum puisque vous ignorez les solutions qu'on vous propose ?

Et pourquoi ne pas continuer avec l'ami ?

Il est vrai qu'il n'est pas au top niveau, voyez quand même le fichier joint et cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim pct, coul, s, lig, i%
pct = Array(0, 0.1, 0.2)
coul = Array(Shapes("Oval 21").Fill.ForeColor, Shapes("Oval 22").Fill.ForeColor, Shapes("Oval 23").Fill.ForeColor)
s = Split("Tete Bras_D Bras_G Torse Dos Main_D Main_G Jambe_D Jambe_G Pied_D Pied_G Cuir")
lig = Split("9 10 10 11 12 13 13 14 14 14 14 15")
For i = 0 To UBound(s)
    Shapes(s(i)).Fill.ForeColor = coul(Application.Match(Range("O" & lig(i)), pct) - 1)
Next
End Sub

A+

 

[MistereVBA]

Je comprends votre réaction et j'en suis désolé, vous n'avez tout simplement pas tout les tenants et aboutissants de l'histoire.
Désolé de vous avoir frustré.

Merci pour vos réponse rapide et vos compétences de VBA.
C'est avec plaisir que je reviendrais sur ce forum en cas de besoin !

 

[job75]

Re,

Notez qu'en N9:N16 il vaut mieux utiliser SOMME.SI.

Et qu'en O9:O16 vos calculs des pourcentages n'avaient ni queue ni tête.

A+