MACRO CARTE DE CHALEUR - CODE TROP LONG
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
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!
.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 WithA+
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 SubUn grand merci pour votre rapidité. C'est parfait.
Merci