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

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
 

virdg

XLDnaute Nouveau
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
merci bcp ;)
 

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: 19
  • bb.JPG
    bb.JPG
    24.2 KB · Affichages: 18

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
 

virdg

XLDnaute Nouveau
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
merci du coup je vous donne le fichier pour l'adapter
 

Pièces jointes

  • TEST site.xlsm
    28.3 KB · Affichages: 1

virdg

XLDnaute Nouveau
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
merci du coup je vous donne le fichier pour l'adapter
 

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
 

virdg

XLDnaute Nouveau
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
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 ;)
 

fanch55

XLDnaute Barbatruc
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 ;)
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
 

virdg

XLDnaute Nouveau
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
c'est le même code la non ?
 

Discussions similaires

Réponses
17
Affichages
611

Statistiques des forums

Discussions
311 720
Messages
2 081 900
Membres
101 834
dernier inscrit
Jeremy06510