Microsoft 365 copie de couleur d'une cellule à une autre sous condition

V

virdg

XLDnaute Nouveau
bonjour a tous,
voila mon soucis;
sur ma feuille de calcul 1
j'ai une liste de nom de couleur dans une colonne A (chaque cellule a une couleur du nom de la couleur )
exemple : A1 : magenta (coloré en magenta) B1 : 1
A2 : cyan (coloré en cyan) B2 : 2
A3 : yellow (coloré en jaune) B3 : 3
etc etc (j'en ai plus de 450),
a chaque couleur est associé un chiffre dans la colonne B
sur ma feuille de calcul 2
je voudrais rentrer les valeurs se trouvant dans la colonne B de la feuille 1 et que la cellule se mettent de la même couleur
Autrement dit quand je rentre la valeur 1 je veux que la cellule se colore en magenta
" " " 2 " " cyan
" " " 3 " " yellow
etc etc
quelqu'un aurait il une idée ? merci
 
Trier par date Trier par votes
V

virdg

XLDnaute Nouveau
fanch55 à dit:
Enrichi (BBcode): 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Range
Dim Lob As ListObject
Set Lob = Worksheets("Feuil1").ListObjects(1)
Application.EnableEvents = False
    If Target.Address = [C1].Address Then
        Set C = Lob.ListColumns("Couleurs").DataBodyRange.Find(Target, , xlValues, xlWhole)
        If Not C Is Nothing Then
            Target.Interior.Color = C.Interior.Color
            [D2].Value = Lob.ListColumns("Libellé").DataBodyRange.Rows(C.Row - Lob.DataBodyRange.Row + 1)
        Else
            Target.Interior.Color = xlNone
        End If
    End If
Application.EnableEvents = True
End Sub
Cliquez pour agrandir...
merci bcp ;)
 
Vote positif 0 Vote négatif
V

virdg

XLDnaute Nouveau
bonjour c'est encore moi :)
dans le tableau 1 j'ai ma liste de teintes avec leurs noms et les proportions d'encre pour les realiser. Grace à vous je sais déjà comment faire pour que dans le partie 2 (qui n'est pas un tableau mais une plage de cellule ) la premiere cellule se remplisse de la couleur et aussi que sonn nom s'affiche dans la cellule suivante mais je voudrais que les proportions s'affichent automatiquement comme sur l'exemple. et quand une encre n'est pas utilisée elle ne doit pas apparaitre dans le tableau
 

Pièces jointes

  • aa.JPG
    aa.JPG
    26.4 KB · Affichages: 20
  • bb.JPG
    bb.JPG
    24.2 KB · Affichages: 19
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
Salut, sans classeur joint, le code pourrait être :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Range, Fcell As Range, Rw As Long
Dim Lob As ListObject: Set Lob = Worksheets("Feuil1").ListObjects(1)
Application.EnableEvents = False

Select Case True
    Case Target.Count > 1
    Case Target.Column > 1
    Case Else
        Set C = Lob.ListColumns("Couleurs").DataBodyRange.Find(Target, , xlValues, xlWhole)
        If Not C Is Nothing Then
            Target.Interior.Color = C.Interior.Color
            Rw = C.Row - Lob.DataBodyRange.Row + 1
            Target.Offset(, 1).Value = Lob.ListColumns("Noms").DataBodyRange.Rows(Rw)
            Set Fcell = Target.Cells(1).Offset(, 2)
            For Each C In Lob.Parent.Range(Lob.Name & "[[Encre 1]:[Encre 4]]").Rows(Rw).Cells
                If C <> "" Then
                    Fcell.Resize(, 2) = Array(Lob.ListColumns(C.Column), C)
                    Set Fcell = Fcell.Offset(1)
                End If
            Next
        Else
            Target.Interior.Color = xlNone
        End If
End Select

Application.EnableEvents = True
End Sub
 
Vote positif 0 Vote négatif
V

virdg

XLDnaute Nouveau
fanch55 à dit:
Salut, sans classeur joint, le code pourrait être :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Range, Fcell As Range, Rw As Long
Dim Lob As ListObject: Set Lob = Worksheets("Feuil1").ListObjects(1)
Application.EnableEvents = False

Select Case True
    Case Target.Count > 1
    Case Target.Column > 1
    Case Else
        Set C = Lob.ListColumns("Couleurs").DataBodyRange.Find(Target, , xlValues, xlWhole)
        If Not C Is Nothing Then
            Target.Interior.Color = C.Interior.Color
            Rw = C.Row - Lob.DataBodyRange.Row + 1
            Target.Offset(, 1).Value = Lob.ListColumns("Noms").DataBodyRange.Rows(Rw)
            Set Fcell = Target.Cells(1).Offset(, 2)
            For Each C In Lob.Parent.Range(Lob.Name & "[[Encre 1]:[Encre 4]]").Rows(Rw).Cells
                If C <> "" Then
                    Fcell.Resize(, 2) = Array(Lob.ListColumns(C.Column), C)
                    Set Fcell = Fcell.Offset(1)
                End If
            Next
        Else
            Target.Interior.Color = xlNone
        End If
End Select

Application.EnableEvents = True
End Sub
Cliquez pour agrandir...
merci du coup je vous donne le fichier pour l'adapter
 

Pièces jointes

  • TEST site.xlsm
    28.3 KB · Affichages: 1
Vote positif 0 Vote négatif
V

virdg

XLDnaute Nouveau
fanch55 à dit:
Salut, sans classeur joint, le code pourrait être :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Range, Fcell As Range, Rw As Long
Dim Lob As ListObject: Set Lob = Worksheets("Feuil1").ListObjects(1)
Application.EnableEvents = False

Select Case True
    Case Target.Count > 1
    Case Target.Column > 1
    Case Else
        Set C = Lob.ListColumns("Couleurs").DataBodyRange.Find(Target, , xlValues, xlWhole)
        If Not C Is Nothing Then
            Target.Interior.Color = C.Interior.Color
            Rw = C.Row - Lob.DataBodyRange.Row + 1
            Target.Offset(, 1).Value = Lob.ListColumns("Noms").DataBodyRange.Rows(Rw)
            Set Fcell = Target.Cells(1).Offset(, 2)
            For Each C In Lob.Parent.Range(Lob.Name & "[[Encre 1]:[Encre 4]]").Rows(Rw).Cells
                If C <> "" Then
                    Fcell.Resize(, 2) = Array(Lob.ListColumns(C.Column), C)
                    Set Fcell = Fcell.Offset(1)
                End If
            Next
        Else
            Target.Interior.Color = xlNone
        End If
End Select

Application.EnableEvents = True
End Sub
Cliquez pour agrandir...
merci du coup je vous donne le fichier pour l'adapter
 
Vote positif 0 Vote négatif
V

virdg

XLDnaute Nouveau
j'ai bien essayé d'inserer le code (en changeant le nom de "ecnre 1 , encre2, en cyan magent yellow black comme dans mon tableau mis a jour mais j'ai une erreur

Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Range
Dim Lob As ListObject
Set Lob = Worksheets("Feuil1").ListObjects(1)
Application.EnableEvents = False 'a quoi sert cette ligne ?


If Target.Address = [A2].Address Then
Set C = Lob.ListColumns("Couleurs").DataBodyRange.Find(Target, , xlValues, xlWhole)
If Not C Is Nothing Then
Target.Interior.Color = C.Interior.Color
[B2].Value = Lob.ListColumns("Noms").DataBodyRange.Rows(C.Row - Lob.DataBodyRange.Row + 1)

Target.Font.Color = C.Interior.Color
Else
Target.Interior.Color = xlNone
End If
'efface le nom si la case du numéro est vide ou effacé"
If C Is Nothing Then
Range("B2").MergeArea.ClearContents
End If
End If


If Target.Address = [A7].Address Then
Set C = Lob.ListColumns("Couleurs").DataBodyRange.Find(Target, , xlValues, xlWhole)
If Not C Is Nothing Then
Target.Interior.Color = C.Interior.Color
[B7].Value = Lob.ListColumns("Noms").DataBodyRange.Rows(C.Row - Lob.DataBodyRange.Row + 1)

'met le texte de la meme couleur que le fond afin de ne pas le voir
Target.Font.Color = C.Interior.Color
Else
Target.Interior.Color = xlNone
End If
'efface le nom si la case du numéro est vide ou effacé"
If C Is Nothing Then
Range("B7").MergeArea.ClearContents
End If
End If


Select Case True
Case Target.Count > 1
Case Target.Column > 1
Case Else
Set C = Lob.ListColumns("Couleurs").DataBodyRange.Find(Target, , xlValues, xlWhole)
If Not C Is Nothing Then
Target.Interior.Color = C.Interior.Color
Rw = C.Row - Lob.DataBodyRange.Row + 1
Target.Offset(, 1).Value = Lob.ListColumns("Noms").DataBodyRange.Rows(Rw)
Set Fcell = Target.Cells(1).Offset(, 2)
For Each C In Lob.Parent.Range(Lob.Name & "[[cyan]:[magenta]:[yellow]:[black]]").Rows(Rw).Cells
If C <> "" Then
Fcell.Resize(, 2) = Array(Lob.ListColumns(C.Column), C)
Set Fcell = Fcell.Offset(1)
End If
Next
Else
Target.Interior.Color = xlNone
End If
End Select

Application.EnableEvents = True
End Sub
Sub Set_Event()
Application.EnableEvents = True
End Sub


encore un grand merci pour ton aide
 
Vote positif 0 Vote négatif
V

virdg

XLDnaute Nouveau
fanch55 à dit:
de la première colonne à la dernière existante:
VB: 
           ' on scrute toutes les cellules de la colonne Cyan à Black
            For Each C In Lob.Parent.Range(Lob.Name & "[[cyan]:[black]]").Rows(Rw).Cells
Cliquez pour agrandir...
j'avais trouvé après avoir posé la question, je progresse doucement , par contre si je veux que les ingredients (les encres) se mettent 2 colonnes après les proportions comment faut il modifer le code ? j'essai de faire varier les valeurs dans le code mais ca ne bouge pas dans le sens que je veux ;)
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
virdg à dit:
j'avais trouvé après avoir posé la question, je progresse doucement , par contre si je veux que les ingredients (les encres) se mettent 2 colonnes après les proportions comment faut il modifer le code ? j'essai de faire varier les valeurs dans le code mais ca ne bouge pas dans le sens que je veux ;)
Cliquez pour agrandir...
Il faut modifier les Offsets (décalage) et les resize ( attention aux cellules fusionnées ), faites appel à votre logique .
VB: 
            Target.Offset(, 1).Value = Lob.ListColumns("Noms").DataBodyRange.Rows(Rw)
            Set Fcell = Target.Cells(1).Offset(, 3)
           ' on scrute toutes les cellules de la colonne Cyan à Black
            For Each C In Lob.Parent.Range(Lob.Name & "[[cyan]:[black]]").Rows(Rw).Cells
                If C <> "" Then
                    Fcell.Resize(, 2) = Array(Lob.ListColumns(C.Column), C)
                    Set Fcell = Fcell.Offset(1)
                End If
            Next
 
Vote positif 0 Vote négatif
V

virdg

XLDnaute Nouveau
fanch55 à dit:
Il faut modifier les Offsets (décalage) et les resize ( attention aux cellules fusionnées ), faites appel à votre logique .
VB: 
            Target.Offset(, 1).Value = Lob.ListColumns("Noms").DataBodyRange.Rows(Rw)
            Set Fcell = Target.Cells(1).Offset(, 3)
           ' on scrute toutes les cellules de la colonne Cyan à Black
            For Each C In Lob.Parent.Range(Lob.Name & "[[cyan]:[black]]").Rows(Rw).Cells
                If C <> "" Then
                    Fcell.Resize(, 2) = Array(Lob.ListColumns(C.Column), C)
                    Set Fcell = Fcell.Offset(1)
                End If
            Next
Cliquez pour agrandir...
c'est le même code la non ?
 
Vote positif 0 Vote négatif

Discussions similaires

treza88
  • Question
Microsoft 365 Copie de couleur d'une cellule à une autre
Réponses
11
Affichages
553
Dranreb
Dranreb
D
  • Question
Microsoft 365 mise en forme conditionnelle : choisir la couleur d'une autre cellule
Réponses
11
Affichages
422
deuxnid
D
lfacq34
  • Question
XL 2016 Reproduction de cellule avec format (couleur, police...)
Réponses
6
Affichages
269
lfacq34
lfacq34
Yann71
  • Question
Microsoft 365 Compter le nombre de cellule mise en couleur avec MFC
2
Réponses
19
Affichages
651
job75
job75
M
  • Question
Autres Mettre en couleur des cellules depuis une date de début jusqu'a la date de fin
Réponses
10
Affichages
250
mcl
M
M
  • Question
XL 2016 Changement de couleur cellule
Réponses
1
Affichages
196
Gégé-45550
Gégé-45550
T
  • Question
XL 2021 Additionner la couleur du fond et la police de plusieurs cellule en vba
Réponses
7
Affichages
312
Tophe2
T
treza88
  • Question
Microsoft 365 Fonction perso ref couleur Hexa en couleur de fond de cellule
2
Réponses
24
Affichages
833
Dudu2
Dudu2
P
  • Résolu(e)
XL pour MAC Problème de changement de couleur de la valeur d'une cellule
Réponses
2
Affichages
241
pvander
P
jeanmi
  • Question
XL 2010 Copier cellule avec mise en forme d’une feuille sur l’autre
Réponses
12
Affichages
300
jeanmi
jeanmi

Membres actuellement en ligne

4 membres et 61 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 782
Messages
2 112 921
Membres
111 702
dernier inscrit
ELEHMAEA