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

virdg · 3 Mars 2023

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 · 14 Mars 2023

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

merci bcp

virdg · 15 Mars 2023

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

fanch55 · 15 Mars 2023

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 · 16 Mars 2023

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

merci du coup je vous donne le fichier pour l'adapter

virdg · 16 Mars 2023

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

merci du coup je vous donne le fichier pour l'adapter

virdg · 16 Mars 2023

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

fanch55 · 16 Mars 2023

Classeur adapté

virdg · 16 Mars 2023

fanch55 à dit:
Classeur adapté

merci beaucoup voila ce que je cherchais , et merci pour les explications dans le code, même si je ne comprends pas tout.

virdg · 16 Mars 2023

fanch55 à dit:
Classeur adapté

si jamais je voulais rajouter une colonne ou deux par exemple rose et vert comment je change le code pour que ça fonctionne ?

fanch55 · 16 Mars 2023

virdg à dit:
si jamais je voulais rajouter une colonne ou deux par exemple rose et vert comment je change le code pour que ça fonctionne ?

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

virdg · 16 Mars 2023

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

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 · 16 Mars 2023

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

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 · 16 Mars 2023

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

c'est le même code la non ?

fanch55 · 16 Mars 2023

virdg à dit:
c'est le même code la non ?

tout à fait, à vous de jouer, je ne sais pas ce que vous avez en tête ....

virdg · 16 Mars 2023

fanch55 à dit:
tout à fait, à vous de jouer

ah oui je me disais aussi , j'essai depuis tout à l'heure... je persévère et je vous tiens au courant

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

virdg

XLDnaute Nouveau

virdg

XLDnaute Nouveau

virdg

XLDnaute Nouveau

Pièces jointes

fanch55

XLDnaute Barbatruc

virdg

XLDnaute Nouveau

Pièces jointes

virdg

XLDnaute Nouveau

virdg

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

Pièces jointes

virdg

XLDnaute Nouveau

virdg

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

virdg

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

virdg

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

virdg

XLDnaute Nouveau

Discussions similaires