tester le remplissage couleur d'une cellule pour le reproduire [Résolu]

[kyros21]

bonjour à tous, voila , j'aimerai pouvoir tester en vba, la couleur de remplissage d'une cellule, afin d'en recuperer la valeur, et pouvoir ainsi effectuer le remplissage de la cellule que je désire.

etant débutant je vous avoue que j'ai énormément de mal,
mise a part la commande
Interior.colorIndex , je ne sais pas comment faire.

Merci de votre aide

[Daniel.C]

Bonjour,

Dans un module standard, mets :

Code :

1
2
3
4
5
6
7
8
9
Public Couleur As Double
 
Sub RecuperationCouleur()
    Couleur = Selection.Interior.Color
End Sub
 
Sub ApplicationCouleur()
    Selection.Interior.Color = Couleur
End Sub

La première macro récupère la couleur de la cellule active. La seconde applique la couleur à la cellule active.

[kyros21]

merci, et si je souhaite cibler la ou les cellules ou on récupere et ou on recopie?

Merci de votre aide

[Daniel.C]

Code :

1
2
3
4
5
6
7
8
9
10
11
Sub RecuperationCouleur()
    Dim c As Range
    Set c = Application.InputBox("Choisissez la cellule source", Type:=8)
    If Not c Is Nothing Then Couleur = c.Interior.Color
End Sub
 
Sub ApplicationCouleur()
    Dim c As Range
    Set c = Application.InputBox("Choisissez la cellule cible", Type:=8)
    If Not c Is Nothing Then c.Interior.Color = Couleur
End Sub

[kyros21]

merci beaucoup pour votre aide, mais entre temps, j'ai abouti à sa :

En fait le but de cette macro est de récupéré le remplissage d'une série de cellule en ligne sur la feuille "Top20 répartition h MO" ( ces cellules vont de G1 jusqu'à trouver une cellule vide)
et de recopier ce remplissage sur un serie de cellule en colonne sur la feuille: Comparatif répartition, à partir de la cellule A5 jusqu'à l'arrêt de la boucle,
par la condition de trouver une cellule vide sur la page Top20 répartition h MO
ce remplissage est copié en plus dans les cellule B5 et B5+1 associé,

vous trouverez en premier une fonction qui permet de transcrire les lettres des colonnes en chiffre pour pouvoir les incrémenter dans ma boucle.

malheureusement ma macro ne passe pas , erreur range de l'objet global a échoué, à la ligne en rouge

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
Function xlColumnValue(strColumnIndex As String) As String
' ------------------------------------------------------------------------------
'
' These function changes the Column Number of a cell in character(s)
' or vice versa.
'
' Return: Column Number or Character
'
' ------------------------------------------------------------------------------
 
 strColumnIndex = UCase(strColumnIndex)
 
Select Case Asc(strColumnIndex)
Case 36 ' Absolute Column
xlColumnValue = xlColumnValue(Mid(strColumnIndex, 2, _
InStr(2, strColumnIndex, "$") - 2))
Case 48 ' 0 in first character
MsgBox "The number 0 is invalid.", vbExclamation, "Null Denied"
Case 49 To 57 ' Number to Char
If strColumnIndex < 27 Then
xlColumnValue = Chr(strColumnIndex + 65 - 1)
Else
If strColumnIndex Mod 26 <> 0 Then
xlColumnValue = Chr(strColumnIndex \ 26 + 65 - 1) + _
Chr(strColumnIndex Mod 26 + 65 - 1)
Else
xlColumnValue = Chr(strColumnIndex \ 26 + 65 - 2) + _
Chr(90)
End If
End If
Case 65 To 90 ' Char To Number
xlColumnValue = Asc(strColumnIndex) - 65 + 1
If Len(strColumnIndex) > 1 Then
xlColumnValue = xlColumnValue * 26 + Asc(Right(strColumnIndex, 1)) - 65 + 1
End If
Case Else
MsgBox "Not yet implemented or Error", vbExclamation, "Error"
End Select
End Function

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Recuperation_couleur()

Dim u, v, µ As Integer

u = 5
v = u + 1
µ = 7
While Sheets("'Comparatif répartition'!Au").Select = 0
'While "'Comparatif répartition'!Au" = 0'

'recupere la couleur de la ligne'
Do
    Couleur = Range("'Top20 répartition h MO'!xlColumnValue(µ)1").Interior.ColorIndex
    µ = µ + 4
'Recopie les remplissages couleurs à partir des couleurs récupérées'
    Range("'Comparatif répartition'!Au,Bu,Bv").Interior.ColorIndex = Couleur
    u = u + 2
    v = v + 2
    Loop
     MsgBox "Procédure terminée"
Wend

End Sub

Visiblement l'erreur apparait
merci de votre aide

[Daniel.C]

Tu aurais pu donner ces explications dans ton message initial, ça m'aurait évité de perdre du temps. Ça représente quoi, ça :

xlColumnValue(µ)1

[kyros21]

voici donc l'etat de la macro , mais elle est bourré d'erreur , que je ne comprends qu'a moitié ... voici son état :
pour ce qui est de xlColumnValue(), cela fait appel à la fonction qui est plus haut, et qui permet de transcrire une colonne en numero, ou un numero en colonne, par exemple :

Si je tape xlColumnValue(3), cela me sort C, car C est la 3 eme lettre de l'alphabet,
Si je tape xlColumnValue(D), cela me sort 4 , car 4 est la 4 eme lettre de l'alphabe. Voila

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Recuperation_couleur()

Dim u, v, mavar As Integer

u = 5
v = u + 1
mavar = 7
While Sheets("Comparatif répartition").Activate  Range("Au").Value = 0
' Ici ya une erreur, je voudrai lui faire verifier dans la feuille Comparatif répartition, la cellule Au ( sachant que u est une variable au départ égale à 5 )

'recupere la couleur de la ligne'
Do
    Couleur = Range("'Top20 répartition h MO'!xlColumnValue(mavar)1").Interior.ColorIndex
    mavar = mavar + 4
'Recopie les remplissages couleurs à partir des couleurs récupérées'
    Range("'Comparatif répartition'!Au,Bu,Bv").Interior.ColorIndex = Couleur
    u = u + 2
    v = v + 2
    Loop
     MsgBox "Procédure terminée"
Wend

End Sub

merci bcp pour votre aide

[Daniel.C]

Si je tape xlColumnValue(3), cela me sort C, car C est la 3 eme lettre de l'alphabet,
Si je tape xlColumnValue(D), cela me sort 4 , car 4 est la 4 eme lettre de l'alphabe. Voila

Donc, on peut supposer que tu désignes la cellule C1 :

Code :

Couleur = Range("'Top20 répartition h MO'!xlColumnValue(µ)1").Interior.ColorIndex

si µ = 3. IL faut écrire :

Code :

Couleur = Sheets("Top20 répartition h MO").Cells(1, xlcolumnsvalue(µ)).Interior.ColorIndex

[kyros21]

bonjour merci beaucoup pour votre aide, mais me voila encore bloqué;
bon j'ai avancé sur la chose, j'ai viré la fonction de transcription des colonnes qui ne sert a rien vu qu'on peut appeler les colonnes par des numéros, donc il y a simplement la variable mavar à la place, mais j'ai toujour des erreurs n'appartient pas a la selection sur les lignes rouges... je ne comprends pas , l'écriture m'a l'air correcte pourtant

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub Recuperation_couleur()

Dim u, v, mavar As Integer

u = 5
v = u + 1
mavar = 7

Do Until Worksheets("Top20 répartition h MO").Cells(u, 1).Value = ""

'recupere la couleur de la ligne'

    Couleur = Worksheets("Top20 répartition h MO").Cells(1, mavar).Interior.ColorIndex
    mavar = mavar + 4
'Recopie les remplissages couleurs à partir des couleurs récupérées'
    Sheets("Comparatif répartition").Union(Cells(u, 1), Cells(u, 2), Cells(v, 2)).Interior.ColorIndex = Couleur
    u = u + 2
    v = v + 2
    Loop
     MsgBox "Procédure terminée"
End Sub

merci encore

[Daniel.C]

je ne comprends pas , l'écriture m'a l'air correcte pourtant

Pourtant quoi ?

[kyros21]

pourtant j'ai des erreurs : " n'appartient pas a la selection " sur les lignes rouges ...

[Daniel.C]

La macro fonctionne ici, après une correction. Vérifie le nom de tes feuilles et la valeur de tes 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
Sub Recuperation_couleur()
 
Dim u, v, mavar As Integer
 
u = 5
v = u + 1
mavar = 7
 
Do Until Worksheets("Top20 répartition h MO").Cells(u, 1).Value = ""
 
'recupere la couleur de la ligne'
 
Couleur = Worksheets("Top20 répartition h MO").Cells(1, mavar).Interior.ColorIndex
mavar = mavar + 4
'Recopie les remplissages couleurs à partir des couleurs récupérées'
With Sheets("Comparatif répartition")
    Union(.Cells(u, 1), .Cells(u, 2), .Cells(v, 2)).Interior.ColorIndex = Couleur
End With
u = u + 2
v = v + 2
Loop
MsgBox "Procédure terminée"
End Sub

[kyros21]

Un grand merci, la macro fonctionne à merveille ,

merci beaucoup