Récupérer la couleur d'une case excel, pour l'appliquer lors d'une mise en forme

Version imprimable

Bonjour à tous,

Tout d'abord, je suis un pur débutant dans VBA excel et je n'ai que quelques notions de programmation générale.

Je souhaites améliorer une macro créer par un tiers, afin de me faciliter la vie.

Je dispose d'une feuille "données" et d'une feuille dans laquelle est mis en forme les informations contenues dans la feuille "données".
Pour cela, je clique sur un bouton dans la feuille " données" paramétré pour lancer une macro VBA, qui met l'ensemble des données en forme dans la deuxième feuille donc.

Actuellement, la couleur utilisé pour formaté les cases d'une ligne dans la deuxième feuille (le résultat de la mise en forme) est fixée(bleu), je souhaiterai récuperer la couleur du fond de la cellule utilisée (ciblé en gris, si j'ai bien compris) pour l'appliquée lors de la mise en forme, à la place de la couleur fixée (RGB(200, 200, 200))

La parti en orange est un de mes essais, non concluant, dans laquelle vous allez sans doute pour certain, voir mon newbeeisme dans la matière :-)
Code:

1 2 3 4 5 6 7 8 9 With Worksheets(PMpav).Shapes.AddShape(msoShapeRectangle, xpav(numtypeop%, codop, nbmvt%), ypav(numtypeop%, codop, nbmvt%) + hauteur_tâche%, durée_mvt(numtypeop%, codop, nbmvt%) * Echellex, hauteur_autres%) .TextFrame.Characters.Text = Worksheets(PMdon).Cells(rm, cl_instruction%).Value .TextFrame.Characters.Font.Bold = True .Fill.ForeColor.RGB = RGB(200, 200, 200) '.Fill.Interior.ColorIndex = Worksheets(PMdon).Cells(rm, cl_instruction%).Interior.ColorIndex .TextFrame.Characters.Font.Size = 10 .TextFrame.Characters.Font.Color = RGB(0, 0, 0) .TextFrame.HorizontalAlignment = xlHAlignCenter .TextFrame.VerticalAlignment = xlVAlignCenter
J'espère avoir été assez clair,

N'hésitez à me poser des questions bien entendu,

D'avance, je remercie les lecteurs et peut être sauveur, de ce post,

Rémi

Bonjour,

Tu peux éventuellement passer par une fonction (voir code ci-dessous) pour récupérer le code RGB de la cellule et ainsi pouvoir affecter la couleur de celle-ci à ton Shape avec "ForeColor.RGB". Pour le test, pose un Shape sur une feuille, colore la cellule A1 et lance la proc "Test" :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
 
Sub Test()
 
    Dim Tbl() As Long
 
    Tbl() = CouleurRVB(Range("A1"))
 
    ActiveSheet.Shapes(1).Fill.ForeColor.RGB = RGB(Tbl(1), Tbl(2), Tbl(3))
 
End Sub
 
Function CouleurRVB(Cel As Range) As Long()
 
    Dim TblCouleur(1 To 3) As Long
    Dim Couleur As Long
    Dim J As Long
    Dim K As Long
 
    Couleur = Cel.Interior.Color
 
    K = 3
 
    For J = 2 To 0 Step -1
 
        TblCouleur(K) = Couleur \ 256 ^ J
 
        Couleur = Couleur Mod 256 ^ J
 
        K = K - 1
 
    Next J
 
    CouleurRVB = TblCouleur()
 
End Function

Hervé.

ça à l'air de fonctionné...

... en tout cas c'est le principe que je veux appliquer!

Tout d'abord, merci de t'intéresser à mon soucis :-)

J'ai essayé d'adapter le code que tu m'as gracieusement formulé et qui fonctionne sur une page excel de test, au code présent dans mon fichier excel:

Voici les modifs:

Début (variables):

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
 
Sub liss_charges()
 
    Dim num_mvt(12, 20, 50)
    Dim durée_mvt(12, 20, 50) As Single
    Dim durée_cpr(12, 20, 50) As Single
    Dim durée_met(12, 20, 50) As Single
    Dim xpav(12, 20, 50) As Integer
    Dim ypav(12, 20, 50) As Integer
    Dim npavs As Long
    Dim PMdon As Integer 'feuille avec données
    Dim PMpav As Integer ' feuille avec pavés
    Dim Echellex As Integer 'facteur echelle en x
    Dim Echelley As Integer 'facteur echelle en y
    Dim Tbl() As Long
    cl_tâche% = 1
    cl_durée_mét% = 2
    cl_correct_prod% = 3
    cl_num_op% = 4
    cl_autre_poste% = 6
    cl_num_tâche% = 13
    cl_instruction% = 5
    cl_FI_contrôle% = 7
    cl_NumCond% = 10
    cl_heuresparpage = 12
    hauteur_tâche% = 84
    hauteur_autres% = 18
    PMpav = 0
    PMdon = 0
    Nbop = 0
    Nombre_op = 0
    numtypeop% = 1
    nbmvt% = 1
    cadence% = 0
    Echelley% = 165
    rm = 3: CM = 1:
    PMdon = ActiveSheet.Index
    Application.ScreenUpdating = False
 
....

Ensuite la partie qui me concerne réellement:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
If codop <> 0 Then
            'ajout du pavé instruction de la tâche
            With Worksheets(PMpav).Shapes.AddShape(msoShapeRectangle, xpav(numtypeop%, codop, nbmvt%), ypav(numtypeop%, codop, nbmvt%) + hauteur_tâche%, durée_mvt(numtypeop%, codop, nbmvt%) * Echellex, hauteur_autres%)
                .TextFrame.Characters.Text = Worksheets(PMdon).Cells(rm, cl_instruction%).Value
                .TextFrame.Characters.Font.Bold = True
                '.Fill.ForeColor.RGB = RGB(200, 200, 200)
                .Tbl() = CouleurRVB(Cells(rm, cl_instruction%))
                .Fill.ForeColor.RGB = RGB(Tbl(1), Tbl(2), Tbl(3))
                .TextFrame.Characters.Font.Size = 10
                .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                If (durée_mvt(numtypeop%, codop, nbmvt%) * Echellex) < 48 Then
                    .TextFrame.Characters.Font.Size = 6
                End If
                .Select
                For Z% = 1 To npavs
                    .ZOrder msoSendBackward
                Next Z%
            End With

Et enfin, la fonction que j'ai ajouté après le End Sub de la partie précédente:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Function CouleurRVB(Cel As Cells) As Long()
 
    Dim TblCouleur(1 To 3) As Long
    Dim Couleur As Long
    Dim J As Long
    Dim K As Long
 
    Couleur = Cel.Interior.Color
 
    K = 3
 
    For J = 2 To 0 Step -1
 
        TblCouleur(K) = Couleur \ 256 ^ J
 
        Couleur = Couleur Mod 256 ^ J
 
        K = K - 1
 
    Next J
 
    CouleurRVB = TblCouleur()
 
End Function

Mais bien entendu, cela ne fonctionne pas (pas encore :-) ), et j'ai une erreur : "Type défini par l'utilisateur non défini" lors de l'exécution/débogage en me surlignant en bleu

Code:

Function CouleurRVB(Cel As Cells) As Long()

Si tu as/vous avez une idée...

D'avance, merci!

Rémi

Re,

Dans ma fonction, l'argument est une seule cellule (Cel As Range) :

Code:

1
2
 
Function CouleurRVB(Cel As Range) As Long()

et non l'ensemble des cellules (Cel As Cells) :

Code:

1
2
 
Function CouleurRVB(Cel As Cells) As Long()

Sache aussi que Tbl() n'est ni une propriété ni une méthode de l'objet "Shape" donc, pas de point devant !
Un simple test tiré de ton code et qui fonctionne :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
Sub Test()
 
    Dim Tbl() As Long
 
    With Worksheets("Feuil1").Shapes.AddShape(msoShapeRectangle, 0, 0, 50, 30)
 
        .TextFrame.Characters.Text = Worksheets("Feuil1").Cells(10, 1).Value
        .TextFrame.Characters.Font.Bold = True
 
        Tbl() = CouleurRVB(Cells(10, 1))
 
        .Fill.ForeColor.RGB = RGB(Tbl(1), Tbl(2), Tbl(3))
 
        .TextFrame.Characters.Font.Size = 10
        .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
 
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .TextFrame.VerticalAlignment = xlVAlignCenter
 
    End With
 
End Sub
 
Function CouleurRVB(Cel As Range) As Long()
 
    Dim TblCouleur(1 To 3) As Long
    Dim Couleur As Long
    Dim J As Long
    Dim K As Long
 
    Couleur = Cel.Interior.Color
 
    K = 3
 
    For J = 2 To 0 Step -1
 
        TblCouleur(K) = Couleur \ 256 ^ J
 
        Couleur = Couleur Mod 256 ^ J
 
        K = K - 1
 
    Next J
 
    CouleurRVB = TblCouleur()
 
End Function

Hervé.

Merci pour ton aide Hervé, :-)

J'ai adapté le bout de code que tu viens de me donner.
Donc actuellement, je n'ai plus de problème lors du débogage, mais les "shapes" générées restent blanches :-(
J'ai même essayé pour cela de remplir PMdon d'une couleur particulière, pour voir si n'il y avait pas un offset, pour x raison, et pas moyen de changer la couleur!

Voici mon bout de code actuel :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
        If codop <> 0 Then
            'ajout du pavé instruction de la tâche
            With Worksheets(PMpav).Shapes.AddShape(msoShapeRectangle, xpav(numtypeop%, codop, nbmvt%), ypav(numtypeop%, codop, nbmvt%) + hauteur_tâche%, durée_mvt(numtypeop%, codop, nbmvt%) * Echellex, hauteur_autres%)
                .TextFrame.Characters.Text = Worksheets(PMdon).Cells(rm, cl_instruction%).Value
                .TextFrame.Characters.Font.Bold = True
                '.Fill.ForeColor.RGB = RGB(200, 200, 200)
                Tbl() = CouleurRVB(Cells(rm, cl_instruction%))
                .Fill.ForeColor.RGB = RGB(Tbl(1), Tbl(2), Tbl(3))
                .TextFrame.Characters.Font.Size = 10
                .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
                .TextFrame.HorizontalAlignment = xlHAlignCenter
                .TextFrame.VerticalAlignment = xlVAlignCenter
                If (durée_mvt(numtypeop%, codop, nbmvt%) * Echellex) < 48 Then
                    .TextFrame.Characters.Font.Size = 6
                End If
                .Select

Rémi

05/06/2015, 16h03
Theze
Re,

Citation:

Donc actuellement, je n'ai plus de problème lors du débogage, mais les "shapes" générées restent blanches :-(

ça ne peut que marcher mais il te faut savoir que quand tu ne parente pas un objet (ici une cellule), le compilateur prend par défaut la feuille active et comme tu appelle la fonction avec "Cells(rm, cl_instruction%)" il se réfère à la cellule de la feuille active située à l'intersection de la ligne rm et de la colonne cl_instruction et si celle-ci est en couleur auto et bien tes Shapes seront de couleur auto :
Code:

1 2 Tbl() = CouleurRVB(Cells(rm, cl_instruction%))
donc plutôt faire :
Code:

1 2 Tbl() = CouleurRVB(Worksheets(PMpav).Cells(rm, cl_instruction))
si c'est la feuille PMpav qui est ta cible.

Hetrvé.

Code:

1
2
3
4
5
6
7
8
    'applique un format
Sub Formatage(ByRef AllRange As Range)
    Dim MyRange As Range
    For Each MyRange In AllRange
        Dico_Format((Dico_Perimetres(MyRange.Value).Format)).Copy
        MyRange.PasteSpecial Paste:=xlPasteFormats
    Next MyRange
End Sub

pour recuperer carement tout le formatage d'une cellule

06/06/2015, 13h12
Theze
Bonjour,

Une façon plus simple. Comme la propriété RGB attend un Long, tu peux utiliser directement la valeur de la propriété Color de la cellule (et non ColorIndex) :
Code:

1 2 .Fill.ForeColor.RGB = Worksheets(PMpav).Cells(rm, cl_instruction%).Interior.Color
Hervé.
07/06/2015, 00h24
interfector1st
Citation:
Envoyé par Theze

Re,

ça ne peut que marcher mais il te faut savoir que quand tu ne parente pas un objet (ici une cellule), le compilateur prend par défaut la feuille active et comme tu appelle la fonction avec "Cells(rm, cl_instruction%)" il se réfère à la cellule de la feuille active située à l'intersection de la ligne rm et de la colonne cl_instruction et si celle-ci est en couleur auto et bien tes Shapes seront de couleur auto :

Code:

1 2 Tbl() = CouleurRVB(Cells(rm, cl_instruction%))

donc plutôt faire :

Code:

1 2 Tbl() = CouleurRVB(Worksheets(PMpav).Cells(rm, cl_instruction))

si c'est la feuille PMpav qui est ta cible.

Hervé.
Bonsoir!

PMpav est le fichier où je viens mettre en forme le shape, c'est sur PMdon que je viens prendre les couleurs, j'ai donc écrit ceci :

Code:

Tbl() = CouleurRVB(Worksheets(PMdon).Cells(rm, cl_instruction))

Tu as bien ciblé mon dernier problème, et cela marche parfaitement maintenant! et j'ai pu améliorer cette macro comme je le souhaitais ( je reprécise que le code d'origine n'est pas de moi, je suis loinnnn d'avoir le niveau, je me vois plus archéologue en train de déchiffrer des hiéroglyphes :-p )

Je ne pensais pas en effet être obligé de recibler une nouvelle fois la cellule qui m'intéresse :-)

Hervé, je te remercie grandement pour ta précieuse aide, tu m'enlèves un rosier du pied ^^,

Je remercie également tamtam64 pour s'être pencher sur mon pb :-)

J'espère que ce post servira à d'autre, pour le sujet est clos :-) :-) :-)

A bientôt,

Rémi