Colorer des formes (rectangles) à partir de la couleur d'autres cellules

bonjour

J'essaie de colorer des formes à partir du fond de remplissage de plusieurs autres cellules (elles-mêmes situées sur une autre feuille que la forme).

• le rectangle "Th1" (située sur la feuille "Animation") afficherait successivement la couleur de la cellule A1, puis de la cellule B1, puis C3, puis A2, puis B2, puis C2, puis A3, B3 et C3 (cellules situées sur la feuille nommée "Th1").
• la rectangle "Th2" (située sur la feuille "Animation") afficherait successivement la couleur de la cellule A1, puis de la cellule B1, puis C3, puis A2, puis B2, puis C2, puis A3, B3 et C3 (cellules situées sur la feuille nommé "Th2").
• la rectangle "Ext1" (située sur la feuille "Animation") afficherait successivement la couleur de la cellule A1, puis de la cellule B1, puis C3, puis A2, puis B2, puis C2, puis A3, B3 et C3 (cellules situées sur la feuille nommé "Ext1").
  
  Auriez-vous un exemple à me montrer ?
  
  > mon fichier comporte 30 formes à colorier sur la feuille « Animation »
  > chaque couleur à utiliser se trouve sur une feuille à part qui porte le même nom que le rectangle qu'elles vont colorier (rectangle Th1 = feuille Th1 pour les couleurs à utiliser)
  > sur chacune de ces feuilles, il y a environ 100 colonnes et 20 lignes (range A1:CU20) de couleurs à utiliser successivement (pour créer une animation visuelle)

Bonjour ruliann, le forum,

Avec un fichier, tu augmenterai tes chances d'obtenir une réponse adaptée....

Cordialement,

@xorsankukai

merci de t'intéresser à mon pblm.

Je joins un fichier pour exemple avec une explication de ce que je souhaite faire dans la dernière feuille. Si ce n'est pas clair fais le moi savoir

Bonjour ruliann, le forum,

Pas sur de comprendre l'intérêt de cette demande, un essai....la macro s’exécute à l'activation de la feuille Animation.

J'espère que tu n'es pas épileptique...

C = C + 0.02  '====>(valeur à ajuster)   40 secondes chez moi

Cordialement,

@xorsankukai

ton code fonctionne super bien, bravo !! La cerise étant que la vitesse des changements de couleurs soit modifiable

pour l'explication de son utilisation : je me suis inspiré d'un fichier qui sert à traiter l'enregistrement de données de températures fournies par 25 thermomètres (23 placés en intérieur, et 2 en extérieur). Les mesures sont faites toutes les 15 min, pendant 21 jours.

l'histoire des changements de couleurs sur la feuille "animation", c'est de passer d'une représentation statique (comme sur les range C26:CT46 des différents onglets) à une représentation dynamique pour voir comment évoluent les locaux entre eux.

Sur l'onglet animation, les rectangles peuvent -selon les besoins de chacun- s'apparenter à des locaux, ou à des réfrigérateurs (pour comparer leur capacité de refroidissement), etc... On peut l'utiliser aussi bien pour des températures que pour comparer des taux d'occupation par exemple.

En regardant l'animation fonctionner, je m'aperçois qu'il manque un repère temporel, car on ne sait pas si on est le matin, le jour, la nuit... Je me dis que ce serait bien qu'il y ait quelque part une cellule qui affiche le jour et une autre qui affiche l'heure, mais c'est vraiment un détail...

L'essentiel est là et je te remercie!

PS: je posterai le fichier dans un message ultérieur lorsque je l'aurai rendu un peu + light

Bonsoir ruliann, le forum,

je m'aperçois qu'il manque un repère temporel, car on ne sait pas si on est le matin, le jour, la nuit... Je me dis que ce serait bien qu'il y ait quelque part une cellule qui affiche le jour et une autre qui affiche l'heure

Un essai....

Cordialement,

super ton timer merci! @xorsankukai

je commence à capter 2/3 trucs au VBA grâce à ce fichier et ton aide. J'ai essayé de modifier ton code pour intégrer un effet de fondu entre le changements de couleurs des shapes. Le code ci-dessous fonctionne, sauf que les shape ne changent plus de couleur simultanément.

En effet le code ci-dessous traite d'abord le changement de couleur (avec le fondu) de la shape1, puis il passe à la shape 2, puis la shape 3, etc... Or, j'aimerais que tous les shapes soient traités en même temps comme dans ton précédent code, mais je n'arrive pas à voir mon erreur dans les modif que j'ai postées ci-dessous

Si tu pouvais me dire ou j'ai merdé ce serait sympa

Public Flag As Boolean

Sub animation()
    Dim sh As Shape, jour, horaire
    Start = Timer: Flag = True
    i = 2
    Do While i <= 22 'dans mon dernier fichier je vais chercher les données sur les lignes 2 à 22 (au lieu de 26 à 46)
        If Flag = False Then Exit Sub
        For j = 3 To 98
            Do While Timer < Start + C
                DoEvents
            Loop
            C = C + 0.02 '====>(valeur à ajuster entre chaque changement de couleur)
            For Each sh In Sheets("Animation").Shapes
                If sh.TextFrame2.TextRange.Characters.Text Like "Th*" Or sh.TextFrame2.TextRange.Characters.Text Like "Ext*" Then
                    Dim targetColor As Long
                    targetColor = Sheets(sh.TextFrame2.TextRange.Characters.Text).Cells(i, j).DisplayFormat.Interior.Color
                    Dim currentColor As Long
                    currentColor = sh.Fill.ForeColor.RGB
                    Dim stepCount As Integer
                    stepCount = 50 ' Nombre d'étapes pour l'effet de fondu (ajustable selon préférences)
                    Dim stepRed As Integer
                    stepRed = (targetColor Mod 256 - currentColor Mod 256) / stepCount
                    Dim stepGreen As Integer
                    stepGreen = ((targetColor \ 256 Mod 256) - (currentColor \ 256 Mod 256)) / stepCount
                    Dim stepBlue As Integer
                    stepBlue = ((targetColor \ 65536) - (currentColor \ 65536)) / stepCount

                    For k = 1 To stepCount
                        If Flag = False Then Exit Sub
                        currentColor = RGB( _
                            currentColor Mod 256 + stepRed, _
                            currentColor \ 256 Mod 256 + stepGreen, _
                            currentColor \ 65536 + stepBlue)
                        sh.Fill.ForeColor.RGB = currentColor

                        ' Mettre à jour la valeur du jour et de l'horaire
                        jour = Sheets(sh.TextFrame2.TextRange.Characters.Text).Cells(i, 2)
                        horaire = Sheets(sh.TextFrame2.TextRange.Characters.Text).Cells(25, j).MergeArea.Cells(1, 1)

                        ' Mettre à jour le texte des formes correspondantes
                        For Each s In Sheets("Animation").Shapes
                            If s.OLEFormat.Object.Name Like "Jour" Then s.TextFrame2.TextRange.Characters.Text = jour
                            If s.OLEFormat.Object.Name Like "Horaire" Then s.TextFrame2.TextRange.Characters.Text = horaire
                        Next s

                        DoEvents
                        Wait 0.02 ' Pause de 0,02 seconde entre chaque étape (ajustable si nécessaire)
                    Next k
                End If
            Next sh
        Next j
        i = i + 1
    Loop
    Flag = False
End Sub

Sub Wait(ByVal seconds As Double)
    Dim endTime As Double
    endTime = Timer + seconds
    Do While Timer < endTime
        DoEvents
    Loop
End Sub

pour finir voici le fichier, pour celles et ceux qui auraient des besoins similaires de représentation :

Pour ce qui est d'avoir un fondu entre chaque changement de couleurs sur les shapes, je propose le code ci-dessous qui reste à améliorer. L'idée était d'intégrer 4 couleurs supplémentaires entre la couleur de départ et la couleur d'arrivée. Mais pour avoir eu un aperçu de ce que donne cet effet de fondu, ben...c'est pas flagrant visuellement (faut attendre les données du jour 3 pour mieux voir les transitions de couleur).

Donc c'est plus pour le plaisir que j'ai cherché une méthode (en utilisant le code fourni par @xorsankukai) que pour le résultat visuel) (moins fun que ce que j'imaginais).

De plus, le fait de rajouter 4 couleurs intermédiaires nécessiterait de réévaluer le timer proposé par xorsankukai car ce dernier ne serait plus cadencé comme il faut (il avancerait 4 fois trop vite par rapport au changement de couleurs des shapes)

bref.... comme occuper un samedi pluvieux

(la macro ci-dessous est dans le module 4 mais la référence de xorsankukai est dans le module 2)

Public Flag As Boolean

Sub animation()
Dim sh As Shape, jour, horaire
Start = Timer: Flag = True
i = 2
Do While i <= 22
If Flag = False Then Exit Sub
For j = 3 To 98
Do While Timer < Start + C
DoEvents
Loop
C = C + 0.02 '====>(valeur à ajuster)

For Each sh In Sheets("Animation").Shapes

If sh.TextFrame2.TextRange.Characters.Text Like "Th*" Or sh.TextFrame2.TextRange.Characters.Text Like "Ext*" Then

' Vérifier si l'animation doit être arrêtée
If Flag = False Then Exit Sub

' Obtenir la couleur de la cellule actuelle (par exemple, C2)
couleurActuelle = Sheets(sh.TextFrame2.TextRange.Characters.Text).Cells(i, j).DisplayFormat.Interior.Color

' Obtenir la couleur de la cellule suivante (par exemple, D2)
couleurSuivante = Sheets(sh.TextFrame2.TextRange.Characters.Text).Cells(i, j + 1).DisplayFormat.Interior.Color

' Diviser la différence de couleur en 4 étapes égales
deltaR = (couleurSuivante Mod 256 - couleurActuelle Mod 256) / 4
deltaG = ((couleurSuivante \ 256) Mod 256 - (couleurActuelle \ 256) Mod 256) / 4
deltaB = ((couleurSuivante \ 65536) Mod 256 - (couleurActuelle \ 65536) Mod 256) / 4

' Calculer le dégradé de 4 nuances entre les deux couleurs
For k = 1 To 4

' Calculer la couleur intermédiaire
r = Int(couleurActuelle Mod 256 + k * deltaR)
g = Int((couleurActuelle \ 256) Mod 256 + k * deltaG)
b = Int((couleurActuelle \ 65536) Mod 256 + k * deltaB)

' Appliquer la couleur intermédiaire à la shape
sh.Fill.ForeColor.RGB = RGB(r, g, b)

' Attendre un court instant pour créer l'effet (ajusté en fonction du nombre d'étapes)
DoEvents

' Temps d'attente entre chaque étape (ajusté en fonction du nombre d'étapes)
WaitTime = 0.02 ' Vous pouvez ajuster cette valeur si nécessaire
WaitStart = Timer
Do While Timer < WaitStart + WaitTime

DoEvents
Loop
Next k

' Mettre à jour la couleur actuelle pour la prochaine itération
couleurActuelle = couleurSuivante


End If

Next sh
Next j
i = i + 1
Loop
Flag = False

End Sub