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

[tweedi]

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

 

[Dranreb]

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

Bonsoir.
Comme ça par exemple:

Sub Rainbow()
Dim L As Long
For L = 1 To 8
   Feuil1.Cells(L, 1).Interior.ColorIndex = Array(7, 3, 46, 6, 10, 8, 5, 21)(L - 1)
   Next L
End Sub

À +

 

[tweedi]

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

Ca marche merci

 

[tweedi]

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 ?



Merci

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

 

[Dranreb]

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]

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

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