exercice: drapeau arc en ciel automatique, problème variable couleur

tweedi

XLDnaute Nouveau
Bonsoir à tous,

Ce soir j'essaie de réaliser le drapeau avec les couleurs de l'arc en ciel. C'est à dire que la macro doit colorer les cellules les unes en dessous des autres avec des couleurs prédéfinies.

Pour moi la difficulté vient du fait que les codes couleurs ne se suivent pas (1 = noir, 2 = blanc, 3 = rouge ce n'es pas dur).

J'ai réussi à le faire mais je trouve le code très lourd:

Sub rainbow()
With Sheets("feuil1")
With .Cells(1, 1).Interior
.ColorIndex = 7
End With
With .Cells(2, 1).Interior
.ColorIndex = 3
End With
With .Cells(3, 1).Interior
.ColorIndex = 46
End With
With .Cells(4, 1).Interior
.ColorIndex = 6
End With
With .Cells(5, 1).Interior
.ColorIndex = 10
End With
With .Cells(6, 1).Interior
.ColorIndex = 8
End With
With .Cells(7, 1).Interior
.ColorIndex = 5
End With
With .Cells(8, 1).Interior
.ColorIndex = 21
End With
End With
End Sub

Je ne pense pas avoir de problème pour la variable des lignes, un "FOR NEXT" devrait faire l'affaire, mais pour les couleurs comment faire pour automatiser ? il faut que la boucle passe d'une valeur à l'autre et dans un ordre précis.

Merci pour votre aide et très bonne soirée à tous ;)

tweedi
 

tweedi

XLDnaute Nouveau
Re : exercice: drapeau arc en ciel automatique, problème variable couleur

Rebonjour

Je reviens vers vous pour savoir pourquoi iol faut mettre (i-1) après le array ?
Je ne comprend pas, je remarque qu'avec un simple i les couleurs sont décalées et il en manque une, mais je ne vois pas pourquoi ?

:confused:

Merci ;)

Edit: je pense enfin avoir trouvé, array commence à 0 n'est-ce pas ?
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Re : exercice: drapeau arc en ciel automatique, problème variable couleur

Bonjour.
Oui c'est cela: la fonction Array définit toujours des tableaux d'indice de départ 0. Donc quand I=1 l'indice est I-1 et toujours aussi ensuite.
Cordialement.
 

Modeste geedee

XLDnaute Barbatruc
Re : exercice: drapeau arc en ciel automatique, problème variable couleur

Bonsour®
Bonsoir à tous,
Ce soir j'essaie de réaliser le drapeau avec les couleurs de l'arc en ciel. C'est à dire que la macro doit colorer les cellules les unes en dessous des autres avec des couleurs prédéfinies.
Pour moi la difficulté vient du fait que les codes couleurs ne se suivent pas (1 = noir, 2 = blanc, 3 = rouge ce n'es pas dur).
tweedi

l'utilisation des colors index est limité à 56 valeurs distinctes.
A partir de Excel 2007 il y a accés à plus de couleurs, mais la gestion passe par l'utilisation des thémes.
il est cependant possible a l'aide de la fonction RGB d'obtenir l'un quelconque des 16 millions et des *** de couleurs "distinctes"

un exemple d'utilisation :Arc-en-ciel + 8 niveau de gris

VB:
Sub PaletteArcEnCiel()
Dim i As Integer, j As Integer, idx As Integer, k As Integer, R As Integer, G As Integer, B As Integer
    ReDim TblR(56)
    ReDim TblG(56)
    ReDim TblB(56)
    ReDim Tblrgb(56)
    ThisWorkbook.Sheets.Add
    Application.ScreenUpdating = False
    [A1] = "Idx": [B1] = "Defaut": [c1] = "Dec": [D1] = "R": [E1] = "G": [F1] = "B": [G1] = "Hex": [H1] = "Arc-en-ciel": [I1] = "Dec": [J1] = "R": [K1] = "G": [L1] = "B": [M1] = "Hex"
    For i = 1 To 7
        For j = 1 To 8
            idx = j + (8 * (i - 1)) ' calcul index de la palette
            k = (j - 1) * 32
            Select Case i
            Case 2
                TblR(idx) = 255:     TblG(idx) = k:       TblB(idx) = 0
            Case 3
                TblR(idx) = 255 - k: TblG(idx) = 255:     TblB(idx) = 0
            Case 4
                TblR(idx) = 0:       TblG(idx) = 255:     TblB(idx) = k
            Case 5
                TblR(idx) = 0:       TblG(idx) = 255 - k: TblB(idx) = 255
            Case 6
                TblR(idx) = k:       TblG(idx) = 0:       TblB(idx) = 255
            Case 1
                TblR(idx) = 255:     TblG(idx) = 0:       TblB(idx) = 255 - k
            Case Else '---- de noir 0,0,0  àblanc 255,255,255)
                TblR(idx) = Round(((j - 1) * 36.425), 0):    TblG(idx) = TblR(idx):    TblB(idx) = TblR(idx)
            End Select
          
            Tblrgb(idx) = RGB(TblR(idx), TblG(idx), TblB(idx))
         
            With ActiveSheet
            .Cells(1 + idx, 1).Value = idx
            .Cells(1 + idx, 2).Interior.ColorIndex = idx
            R = ThisWorkbook.Colors(idx) Mod 256
            G = Int(ThisWorkbook.Colors(idx) / 256 ^ 1) Mod 256
            B = Int(ThisWorkbook.Colors(idx) / 256 ^ 2) Mod 256
             .Cells(1 + idx, 3).Value = ThisWorkbook.Colors(idx)
             .Cells(1 + idx, 4).Value = R
              .Cells(1 + idx, 5).Value = G
               .Cells(1 + idx, 6).Value = B
               .Cells(1 + idx, 7).Value = "&H" & Application.Dec2Hex(B, 2) & Application.Dec2Hex(G, 2) & Application.Dec2Hex(R, 2)
              
            .Cells(1 + idx, 8).Interior.Color = Tblrgb(idx)
              .Cells(1 + idx, 9).Value = Tblrgb(idx)
              .Cells(1 + idx, 10).Value = TblR(idx)
            .Cells(1 + idx, 11).Value = TblG(idx)
            .Cells(1 + idx, 12).Value = TblB(idx)
            .Cells(1 + idx, 13).Value = "&H" & Application.Dec2Hex(TblB(idx), 2) & Application.Dec2Hex(TblG(idx), 2) & Application.Dec2Hex(TblR(idx), 2)
    End With
             '********************************************
            ' affectation RGB à la palette
            ' ThisWorkbook.Colors(idx) = tblrgb(idx)
            '********************************************
        Next
    Next
            '********************************************
            ' restoration palette par defaut
            ' ThisWorkbook.ResetColors
            '********************************************
     Application.ScreenUpdating = True
  End Sub
 

Discussions similaires

Statistiques des forums

Discussions
314 450
Messages
2 109 724
Membres
110 552
dernier inscrit
jasson