Discussion :

[interfector1st]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Theze]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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é.

[interfector1st]

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

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

Function CouleurRVB(Cel As Cells) As Long()

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

D'avance, merci!

Rémi

[Theze]

Re,

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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é.

[interfector1st]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Theze]

Re,

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

donc plutôt faire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

Hetrvé.

[tamtam64]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
.Fill.ForeColor.RGB = Worksheets(PMpav).Cells(rm, cl_instruction%).Interior.Color

Hervé.

[interfector1st]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

donc plutôt faire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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