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

ruliann

XLDnaute Occasionnel
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 :

VB:
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?
 
Solution
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
VB:
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...

ArnaudFaches

XLDnaute Nouveau
Bonjour Ruliann,

Essaye avec quelque chose comme cela ?
VB:
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

XLDnaute Barbatruc
Supporter XLD
Bonjour Ruliann,
Une piste :

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

Dranreb

XLDnaute Barbatruc
Bonjour.
Voir cette source.

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.
 

Pièces jointes

  • CouleurClsDégradé.xlsm
    42.9 KB · Affichages: 5
Dernière édition:

ruliann

XLDnaute Occasionnel
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
++
 

ruliann

XLDnaute Occasionnel
@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.
 

Pièces jointes

  • Classeur1.xlsm
    90.2 KB · Affichages: 3

patricktoulon

XLDnaute Barbatruc
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
1694709565012.png


VB:
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

XLDnaute Barbatruc
sur 20 cellule ca donnerait cela
Code:
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
1694710690769.png
 

ruliann

XLDnaute Occasionnel
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

VB:
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 :



VB:
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

2023-09-14_19h44_00.png
 

Dranreb

XLDnaute Barbatruc
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é):
VB:
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.
Code:
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
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
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
VB:
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
 

Discussions similaires

Statistiques des forums

Discussions
312 817
Messages
2 092 366
Membres
105 379
dernier inscrit
alboub