MACRO CARTE DE CHALEUR - CODE TROP LONG Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
t
tjaillet
Nouveau venu
Nouveau venu
Messages : 2
Inscrit le : 16 octobre 2017
Version d'Excel : 2017

Message par tjaillet » 16 octobre 2017, 18:34

Bonjour à tous.

C'est mon premier post ici, je me lance.

Je cherche à raccourcir un macro trop longue car j'ai le message d'erreur suivant "Erreur de compilation: procédure trop grande"
Effectivement le code est assez long mais c'est une répétition de l'élément ci dessous (80 répétitions).

Je cherche en fait a créer une carte de chaleur.

Je test la valeur d'une cellule qui correspond à une zone. Si elle est égale à 1 alors la zone (forme libre) prend une couleur, si elle est égale à 2 une autre couleur et ce jusque 10.

Est ce que vous connaissez un moyen de raccourcir le code ci dessous ?

Je ne sais pas si je suis clair

Merci

'H49 Freeform 30

If Range("H49").Value = 1 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(255, 255, 255)
End With
End If
If Range("H49").Value = 2 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(153, 102, 101)
End With
End If
If Range("H49").Value = 3 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(167, 89, 89)
End With
End If
If Range("H49").Value = 4 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(180, 76, 77)
End With
End If
If Range("H49").Value = 5 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(192, 64, 65)
End With
End If
If Range("H49").Value = 6 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(205, 51, 51)
End With
End If

If Range("H49").Value = 7 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(218, 38, 39)
End With
End If
If Range("H49").Value = 8 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(229, 25, 26)
End With
End If
If Range("H49").Value = 9 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(242, 12, 12)
End With
End If
If Range("H49").Value = 10 Then
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(254, 0, 0)
End With
End If
Avatar du membre
curulis57
Passionné d'Excel
Passionné d'Excel
Messages : 3'722
Appréciations reçues : 217
Inscrit le : 4 janvier 2016
Version d'Excel : 2016 FR / 2019 FR

Message par curulis57 » 16 octobre 2017, 19:09

Salut tjaillet,

bienvenue sur le forum!

Tu complètes la première ligne avec les RGB correspondant à chaque valeur de Range("H49") avec l'exigence que ces valeurs doivent être continues à partir de 1 : chance, j'en ai déjà mis trois! :lol:
.ForeColor s'occupe du reste!
sRGB = Choose(Range("H49").Value, RGB(255, 255, 255), RGB(153, 102, 101), RGB(167, 89, 89))
ActiveSheet.Shapes.Range(Array("Freeform 30")).Select
With Selection.ShapeRange.Fill
    .ForeColor.RGB = sRGB
End With
:btres:

:D
A+
T
Theze
Passionné d'Excel
Passionné d'Excel
Messages : 4'020
Appréciations reçues : 305
Inscrit le : 26 janvier 2011
Version d'Excel : 2007/2019

Message par Theze » 16 octobre 2017, 19:10

Bonjour,

Je ne trouve pas le code trop long, je pense que l'erreur est ailleurs mais voila une code raccourci :
Sub Test()

    With ActiveSheet.Shapes("Freeform 30")
    
        Select Case Range("H49").Value
        
            Case 1: .Fill.ForeColor.RGB = RGB(255, 255, 255)
            Case 2: .Fill.ForeColor.RGB = RGB(153, 102, 101)
            Case 3: .Fill.ForeColor.RGB = RGB(167, 89, 89)
            Case 4: .Fill.ForeColor.RGB = RGB(180, 76, 77)
            Case 5: .Fill.ForeColor.RGB = RGB(192, 64, 65)
            Case 6: .Fill.ForeColor.RGB = RGB(205, 51, 51)
            Case 7: .Fill.ForeColor.RGB = RGB(218, 38, 39)
            Case 8: .Fill.ForeColor.RGB = RGB(229, 25, 26)
            Case 9: .Fill.ForeColor.RGB = RGB(242, 12, 12)
            Case 10: .Fill.ForeColor.RGB = RGB(254, 0, 0)
        
        End Select
        
    End With

End Sub
Il vaut mieux un qui sait que cent qui cherchent :wink:

Ce forum étant un lieu de partage, je n'accepte pas les messages privés !
t
tjaillet
Nouveau venu
Nouveau venu
Messages : 2
Inscrit le : 16 octobre 2017
Version d'Excel : 2017

Message par tjaillet » 17 octobre 2017, 10:01

Un grand merci pour votre rapidité. C'est parfait.
Merci
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message