Liste déroulante avec conservation de la couleur

[dephazz]

Bonsoir le forum,
Je souhaite qu'à partir de données ayant chacune un fond coloré différent, rentrées sur une feuille excel (A1 à A10 p ex.) et servant de base à une liste déroulante que l'inscription dans une cellule par le biais de la liste déroulante conserve bien entendu la valeur mais aussi le fond coloré qui a été attribué à cette donnée. Les données et les cellules peuvent être sur la même feuille.

Merci de votre aide

 

[BOISGONTIER]

Re : Liste déroulante avec conservation de la couleur

Bonsoir,

Données/Validation

JB

 

[dephazz]

Re : Liste déroulante avec conservation de la couleur

Re,
J'essaye mais je n'y parvient pas.
Ci-joint le fichier
Merci

 

[dephazz]

Re : Liste déroulante avec conservation de la couleur

Peronne pour m'aider ? 😕

 

[jeanpierre]

Re : Liste déroulante avec conservation de la couleur

Bonsoir dephazz, Jacques,

As-tu étudié seulement le lien donné par BOISGONTIER, il t'envoie directement sur la solution de ton problème ?

Juste en dessous de Récupération de couleur, tu as deux fichiers à exploiter (DVlisterécupcouleur et liste Dvjourdemijour).

Ca, on ne peut le faire à ta place, mais si tu ne t'en sors pas, on peut t'aider pour une première question, une deuxième ensuite... etc....

Bonne découverte.

A te lire et bonne soirée.

Jean-Pierre

 

[job75]

Re : Liste déroulante avec conservation de la couleur

Bonsoir dephazz, jeanpierre 🙂

Sinon cette petite macro dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range("B2:K8"))
If Target Is Nothing Then Exit Sub
Dim ref As Range
Set ref = Range("A12:A21").Find(Target.Cells(1, 1), LookIn:=xlFormulas)
If ref Is Nothing Then Target.Interior.ColorIndex = xlNone: Exit Sub
Target.Interior.ColorIndex = ref.Interior.ColorIndex
End Sub

Edit : pardon, je n'avais pas vu JB, que je salue

A+

 

[BOISGONTIER]

Re : Liste déroulante avec conservation de la couleur

Bonjour,

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect([planning], Target) Is Nothing Then
    On Error Resume Next
    Target.Interior.ColorIndex = [couleurs].Find(Target, LookAt:=xlWhole).Interior.ColorIndex
  End If
End Sub

couleurs =Feuil1!$A$12:$A$21
planning =Feuil1!$B$2:$K$8


jb

 

[dephazz]

Re : Liste déroulante avec conservation de la couleur

Re,
Merci Boisgontier et merci Job75, cela fonctionne.
Le problème est que la fonction n'est pas conservée au copier-coller sur la feuille suivante.

 

[job75]

Re : Liste déroulante avec conservation de la couleur

Bonjour dephazz, le fil, le forum,

A placer dans Thisworkbook :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
If Intersect(Source, Sh.Range("B2:K8")) Is Nothing Or Source.Count > 1 Then Exit Sub
Dim ref As Range
Set ref = Sh.Range("A12:A21").Find(Source, LookIn:=xlFormulas)
If ref Is Nothing Then Source.Interior.ColorIndex = xlNone: Exit Sub
Source.Interior.ColorIndex = ref.Interior.ColorIndex
End Sub

Modifications à faire, par exemple si les plannings commencent en 2ème feuille, et que le tableau de couleur soit toujours dans la 1ère :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
If [COLOR="Red"]Sh.Index < 2 Or[/COLOR] Intersect(Source, Sh.Range("B2:K8")) Is Nothing Or Source.Count > 1 Then Exit Sub
Dim ref As Range
Set ref = [COLOR="Red"][test].[/COLOR]Find(Source, LookIn:=xlFormulas)
If ref Is Nothing Then Source.Interior.ColorIndex = xlNone: Exit Sub
Source.Interior.ColorIndex = ref.Interior.ColorIndex
End Sub

Edit : je n'avais pas vu que vous aviez nommé test la plage de couleurs...

A+

 

[job75]

Re : Liste déroulante avec conservation de la couleur

Re,

Une amélioration qui permet l'effacement d'une plage de cellules :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
Set Source = Intersect(Source, Sh.Range("B2:K8"))
If Source Is Nothing Then Exit Sub
If Application.CountA(Source) = 0 Then Source.Interior.ColorIndex = xlNone: Exit Sub 'effacement d'une plage
If Source.Count > 1 Then Exit Sub
Dim ref As Range
Set ref = [test].Find(Source, LookIn:=xlFormulas)
If ref Is Nothing Then Source.Interior.ColorIndex = xlNone: Exit Sub
Source.Interior.ColorIndex = ref.Interior.ColorIndex
End Sub

A+

 

[dephazz]

Re : Liste déroulante avec conservation de la couleur

Merci Job75
J'ai du m'absenter.
Je regarde çà demain
Bonne nuit le forum
🙂

 

[dephazz]

Re : Liste déroulante avec conservation de la couleur

Bonjour job75, bonjour le forum,
J'ai rajouté
"Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range("B2:K8"))
If Target Is Nothing Then Exit Sub
Dim ref As Range
Set ref = Range("A12:A21").Find(Target.Cells(1, 1), LookIn:=xlFormulas)
If ref Is Nothing Then Target.Interior.ColorIndex = xlNone: Exit Sub
Target.Interior.ColorIndex = ref.Interior.ColorIndex
End Sub"
dans workbook mais cela déclenche un message d'erreur et si je bricole la formule, je n'obtiens rien.
Je préfère confier le fichier excel pour analyser le problème dans sa globalité.
Merci d'avance.🙂

 

[JCGL]

Re : Liste déroulante avec conservation de la couleur

Bonjour à tous,

Tu ne peux avoir qu'une :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range

Compile les deux ou adapte

A+ à tous

 

[dephazz]

Re : Liste déroulante avec conservation de la couleur

JCGL a dit:

Tu ne peux avoir qu'une :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range

Compile les deux ou adapte

A+ à tous

Oui merci, je l'avais remarqué. 🙂
J'avais déjà tenté de "bricoler" avant de poster sur le forum mais la liste déroulante fonctionne sans la couleur.
Où est le problème?

 

[job75]

Re : Liste déroulante avec conservation de la couleur

Bonsoir dephazz, JCGL,

C'est bien, même très bien, de couper le projet en petits morceaux, mais il faut apprendre aussi à les remettre ensemble (compiler comme dit JCGL).

En plus vous n'y avez pas mis ma dernière macro (post #10), l'avez vous au moins essayée ??

Et pourquoi aviez-vous mis une macro en feuille 2 ??

Votre fichier "compilé" ci-joint.

A+