XL 2019 Dégradé de couleurs en fonction des couleurs contenues dans 2 cellules

[ruliann]

Bonjour,

En A1 j'ai la cellule qui est colorée en jaune.
En B2 j'ai la cellule qui est colorée en rouge.

J'aimerais créer un dégradé de couleur qui part de la couleur contenue en A1 vers la couleur contenue en B2 (donc du jaune au rouge), un dégradé qui comporterait 15 nuances.

Ces 15 nuances seraient affichées entre A3 et A18.

A l'occasion d'un autre post, j'avais récupéré ce bout de code :

Sub degrade1()
Dim coul&, i&
coul = Cells(1, "A").Interior.Color
For i = 20 To 2 Step -1
Cells(i + 5, "A").Interior.Color = coul
Cells(i + 5, "A").Interior.TintAndShade = ((i - 1) + i / 30) / 20
Next
End Sub

Auriez-vous une idée pour l'adapter à mon problème?

 

[ArnaudFaches]

Bonjour Ruliann,

Essaye avec quelque chose comme cela ?

Sub CreerDegradé()
    Dim coulA As Long, coulB As Long
    Dim i As Integer
    Dim stepSize As Double
    
    ' Définir la couleur de départ (jaune) et la couleur d'arrivée (rouge)
    coulA = Range("A1").Interior.color
    coulB = Range("B2").Interior.color
    
    ' Calculer le pas de changement de couleur
    stepSize = 1 / 14
    
    ' Appliquer les couleurs intermédiaires dans les cellules A3 à A18
    For i = 3 To 18
        Range("A" & i).Interior.color = InterpolateColor(coulA, coulB, (i - 3) * stepSize)
    Next i
End Sub

Function InterpolateColor(ByVal colorA As Long, ByVal colorB As Long, ByVal t As Double) As Long
    Dim redA As Integer, greenA As Integer, blueA As Integer
    Dim redB As Integer, greenB As Integer, blueB As Integer
    Dim redResult As Integer, greenResult As Integer, blueResult As Integer
    
    ' Extraire les composantes RVB des deux couleurs
    redA = colorA Mod 256
    greenA = (colorA \ 256) Mod 256
    blueA = (colorA \ 256 \ 256) Mod 256
    
    redB = colorB Mod 256
    greenB = (colorB \ 256) Mod 256
    blueB = (colorB \ 256 \ 256) Mod 256
    
    ' Interpoler les composantes RVB
    redResult = redA + (redB - redA) * t
    greenResult = greenA + (greenB - greenA) * t
    blueResult = blueA + (blueB - blueA) * t
    
    ' Retourner la couleur résultante
    InterpolateColor = RGB(redResult, greenResult, blueResult)
End Function

 

[sylvanu]

Bonjour Ruliann,
Une piste :

Texte - Dégradé de couleurs

Il peut être intéressant de gérer en automatique un dégradé de couleurs, en particulier pour des shapes ( dpts dans pays par exemple ) La fonction suivante calcule une couleur entre une couleur de début, une couleur de fin et un ratio. Function Dégradé(ByVal X#, Color1, Color2) As Double Dim...

excel-downloads.com

et plus précis si vous fournissez un fichier test.

 

[Dranreb]

Bonjour.
Voir cette source.

Élaboration et utilisation de jeux de couleurs.

Mise au point facile de jeux de couleurs pour UserForm, Shape et cellules, voire images calculées. Possibilité de capturer un pixel n'importe où sur l'écran. Module de classe Couleur pour utilisation dans d'autres projets VBA.

excel-downloads.com

Remarque: la valeur de composante RVB =127 ou 128 correspond généralement à une surface d'éclairage beaucoup plus sombre que la moitié de celle de la valeur 255 à cause du gamma d'écran.
Un dégradé passant par cette cette valeur pour deux composantes différentes chacune à 255 aux deux bouts différent et 0 à l'autre sera donc trop sombre à mi chemin.
Ma classe Couleur permet d'effectuer ces calculs d'après des éclairages plus justes.

 

[ruliann]

merci à vous 3 pour votre réactivité et vos solutions qui correspondent très bien à ma question.

En appliquant vos macros, je me rends compte que mon nuancier établit sur la base de 2 couleurs n'est pas idéal.

En effet, je cherche à reproduire des classes de températures (x classes selon les cas) en respectant un gradient de couleur qui se rapproche de cet exemple (lien).

Et je constate qu'il faudrait renseigner une si ce n'est pas deux couleurs intermédiaires supplémentaires (entre la couleur du début, et la couleur de fin) pour obtenir un résultat ressemblant.

Car dans l'exemple ci-dessus (voir ce lien) on passe en fait du orange vers le jaune, du jaune vers le blanc, du blanc vers le bleu... Si je fais direct un dégradé du orange au bleu, forcément le résultat n'est pas top, je n'y avais pas pensé dsl

Si vous êtes encore motivés pour me proposer votre aide tant mieux! sinon merci encore pour les réponses déjà apportées
++

 

[Dranreb]

Vous voulez le faire par mises en formes conditionnelles ?
Joignez donc plutôt un exemple de classeur.

 

[ruliann]

@Dranreb : non, je ne souhaite pas de MFC pour ce cas. Dans une prochaine étape, j'aurai besoin de récupérer la couleur de chaque nuance du dégradé.

Je joins un exemple.

Le style de dégradé que je cherche à obtenir est en colonne E (c'est pour une échelle de températures). J'aimerais pouvoir faire un dégradé non pas sur la base de 2 couleurs, mais de 4 ou 5 couleurs, en 6 ou 10 ou 15 nuances selon les cas.

 

[patricktoulon]

re
bon jour dans ton lien c'est un dégradé de 4 couleurs
de 0 à 60% c'est orange vers orange 2 puis le blanc et de 61% à 100% c'est blanc vers le bleu
sur un 3 couleurs ca pourrait donner ceci

Sub test()
    Dim C1&, C2&, C3&
    C1 = [A1].Interior.Color
    C2 = [A2].Interior.Color
    C3 = [A3].Interior.Color

    For i = 1 To 6
        Cells(i, 4).Interior.Color = C1
        Cells(i, 4).Interior.TintAndShade = (i / 6)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next

    For i = 10 To 6 Step -1
        x = x + 1
        Cells(i, 4).Interior.Color = C3
        Cells(i, 4).Interior.TintAndShade = (1 / 4) * (x - 1)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next
End Sub

 

[patricktoulon]

sur 20 cellule ca donnerait cela

Sub test()
    Dim C1&, C2&, C3&
    C1 = [A1].Interior.Color
    C2 = [A2].Interior.Color
    C3 = [A3].Interior.Color

    For i = 1 To 12
        Cells(i, 4).Interior.Color = C1
        Cells(i, 4).Interior.TintAndShade = (i / 12)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next

    For i = 20 To 12 Step -1
        x = x + 1
        Cells(i, 4).Interior.Color = C3
        Cells(i, 4).Interior.TintAndShade = (1 / 8) * (x - 1)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next
End Sub

 

[Dranreb]

Je vous ai établi une Function qui calcule une couleur pour une températures en Kelvin

 

[ruliann]

re
bon jour dans ton lien c'est un dégradé de 4 couleurs
de 0 à 60% c'est orange vers orange 2 puis le blanc et de 61% à 100% c'est blanc vers le bleu
sur un 3 couleurs ca pourrait donner ceci
Regarde la pièce jointe 1178737

Sub test()
    Dim C1&, C2&, C3&
    C1 = [A1].Interior.Color
    C2 = [A2].Interior.Color
    C3 = [A3].Interior.Color

    For i = 1 To 6
        Cells(i, 4).Interior.Color = C1
        Cells(i, 4).Interior.TintAndShade = (i / 6)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next

    For i = 10 To 6 Step -1
        x = x + 1
        Cells(i, 4).Interior.Color = C3
        Cells(i, 4).Interior.TintAndShade = (1 / 4) * (x - 1)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next
End Sub

merci, pour tenter de comprendre votre code, j'ai essayé de rajouter une 4 ème couleur sur 15 cellules :

Sub test()
    Dim C1&, C2&, C3&, C4&
    C1 = [A1].Interior.Color
    C2 = [A2].Interior.Color
    C3 = [A3].Interior.Color
    C4 = [A4].Interior.Color

    For i = 1 To 5
        Cells(i, 4).Interior.Color = C1
        Cells(i, 4).Interior.TintAndShade = (i / 5)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next
   
        For i = 10 To 5 Step -1
        x = x + 1
        Cells(i, 4).Interior.Color = C3
        Cells(i, 4).Interior.TintAndShade = (1 / 5) * (x - 1)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next

        For i = 15 To 10 Step -1
        x = x + 1
        Cells(i, 4).Interior.Color = C4
        Cells(i, 4).Interior.TintAndShade = (1 / 5) * (x - 1)
        Cells(i, 4) = Cells(i, 4).Interior.Color
    Next
   
End Sub

Je peine sur le dégradé entre la 3ème couleur et la 4ème... après cela me convient bien, c'est juste pour comprendre

 

[ruliann]

Je vous ai établi une Function qui calcule une couleur pour une températures en Kelvin

merci pour cette version luxe . Et si on souhaitait choisir 4 couleurs avec lesquelles faire notre dégradé, ce serait possible?

 

[Dranreb]

Oui, ce serait possible. Il faudrait une table de correspondance entre les valeurs et les couleurs.
Ce pourrait être une plage avec correspondance des valeurs et couleurs de fond
Par exemple en EHJ (énergie, chaleur gaieté):

Function IntpoCoulEHJ(ByVal V As Double, ByVal Rng As Range) As Long
   Dim L0 As Long, L1 As Long, CLr As New Couleur, _
      V0 As Double, E0 As Double, H0 As Double, J0 As Double, _
      V1 As Double, E1 As Double, H1 As Double, J1 As Double
   If V < Rng(1, 1).Value Then L0 = 1: L1 = 1 Else L0 = WorksheetFunction _
      .Match(V, Rng, 1): L1 = L0 + 1: If L1 > Rng.Rows.Count Then L1 = L0
   With Rng(L0, 1): V0 = .Value: CLr.C = .Interior.Color: End With: E0 = CLr.E: H0 = CLr.H: J0 = CLr.J
   With Rng(L1, 1): V1 = .Value: CLr.C = .Interior.Color: End With: E1 = CLr.E: H1 = CLr.H: J1 = CLr.J
   CLr.EHJ IntpoLin(V, V0, E0, V1, E1), IntpoLin(V, V0, H0, V1, H1), IntpoLin(V, V0, J0, V1, J1)
   IntpoCoulEHJ = CLr.C
   End Function

En EAF (énergie, angle, force) c'est plus compliqué à cause d'un mauvais sens de variation possible de A (l'angle de teinte). Il vaudrait mieux dans ce cas une table avec les 3 colonnes E, A et F.

Function IntpoCoulEAF(ByVal V As Double, ByVal RngTb As Range) As Long
   Dim TV(), TEAF(), L0 As Long, L1 As Long, CLr As New Couleur, _
      V0 As Double, E0 As Double, A0 As Double, F0 As Double, _
      V1 As Double, E1 As Double, A1 As Double, F1 As Double
   TV = RngTb.Columns(1).Value: TEAF = RngTb.Columns(2).Resize(, 3).Value
   If V < TV(1, 1) Then L0 = 1: L1 = 1 Else L0 = WorksheetFunction _
      .Match(V, TV, 1): L1 = L0 + 1: If L1 > UBound(TV, 1) Then L1 = L0
   V0 = TV(L0, 1): E0 = TEAF(L0, 1): A0 = TEAF(L0, 2): F0 = TEAF(L0, 3)
   V1 = TV(L1, 1): E1 = TEAF(L1, 1): A1 = TEAF(L1, 2): F1 = TEAF(L1, 3)
   CLr.EAF IntpoLin(V, V0, E0, V1, E1), IntpoLin(V, V0, A0, V1, A1), IntpoLin(V, V0, F0, V1, F1)
   IntpoCoulEAF = CLr.C
   End Function

 

[Dranreb]

Après un peu de mise au point …

 

[patricktoulon]

re
perso j'ai repris une vielle fonction qui me ramène une couleur vers une autre par pas de X(voulus)
avec une simple sub je l'appelle autant de fois que j'ai de couleur

Sub test()
    Dim q&(1 To 4), Pas&
    q(1) = [A1].Interior.Color
    q(2) = [A2].Interior.Color
    q(3) = [A3].Interior.Color
    q(4) = [A4].Interior.Color
    Pas = 7
    creategradient q(1), q(2), Pas, 1
    creategradient q(2), q(3), Pas, Pas + 1    'pour laisser une blanche
    creategradient q(3), q(4), Pas, Pas * 2
    'on peut la lancer autant de fois que l'on veut
End Sub

Function creategradient(c1&, c2&, FOIS&, start&)
    Dim R, G, B, R2, G2, B2, PartR, PartG, PartB
    B = c1 \ 65536: G = (c1 - B * 65536) \ 256: R = c1 - B * 65536 - G * 256    'conversion rgb de la couleur 1
    B2 = c2 \ 65536: G2 = (c2 - B2 * 65536) \ 256: R2 = c2 - B2 * 65536 - G2 * 256    'conversion rgb de la couleur 2

    PartR = -((R - R2) / FOIS)    'la valeur du pas  négative ou positive de R
    PartG = -((G - G2) / FOIS)    'la  valeur du pas   négative ou positive de G
    PartB = -((B - B2) / FOIS)    'la  valeur du pas   négative ou positive de B

    For i = 1 To FOIS
        R = R + PartR: G = G + PartG: B = B + PartB    'on incrémente avec le pas négatif ou positif

        Cells(i + start - 1, 5).Interior.Color = RGB(R, G, B)
    Next i

End Function