Bonjour a tous
Casefayere et bien soit
Remplace (rnd*255) par(150+(rnd*155))
Pour les 3 tu n'aura pas de couleur trop foncé
Ensuite c est aussi le reste qui est intéressant
Version imprimable
Bonjour a tous
Casefayere et bien soit
Remplace (rnd*255) par(150+(rnd*155))
Pour les 3 tu n'aura pas de couleur trop foncé
Ensuite c est aussi le reste qui est intéressant
là, je n'ai plus le temps mais essayerai d'adapter ta proposition au code
C'est bien la 1ere fois que je vois un duel interessant sur un de mes posts.:aie:
Je vous en suis tout reconnaissant.
Merci a vous deux pour votre aide.
je préfère le terme "duo"Citation:
C'est bien la 1ere fois que je vois un duel interessant
et puis si t rangeais bien tes aliments au congel, on n'aurait pas besoin de faire cette procédure :D:mouarf2:
Je non c'est pas un duel graphychris
Casefayere les couleurs ne vont pas en dessous de rgb(151,151,151 ) dans ma derniere intervention on est donc dans les plus claires cela reduit le nombre de possibilités. Mais on reste a 150puissance3 *150 couleurs ce qui reste assez large en terme de palette couleur
:ptdr::ptdr:Citation:
et puis si t rangeais bien tes aliments au congel, on n'aurait pas besoin de faire cette procédure :D:mouarf2:
toutes les mêmes !!!:mouarf:
Oui effectivement ce n'est pas un duel mais dans le cas precis un BONDUELLE ! ! !:ptdr::ptdr::ptdr::ptdr:
soyons sérieux,
après test, ta proposition me parait impeccable Patrick, j'espère ne pas vexer DeathZarakai
à graphikris
tu peux supprimer le code "couleur" donc dans thisWorkbookdans le code de Feuil1Code:
1
2
3 Private Sub Workbook_Open() demarrage End Sub
et le code "doublon" à remplacer par celui-ci (je n'ai pas vu de défaut)Code:
1
2
3
4
5 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Or Target.Column = 4 Or Target.Column = 7 Or Target.Column = 10 Then Doublon End If End Sub
PS : pour les tests de couleur, tu peux ajouter une variable, exCode:
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 Sub Doublon() Dim mondico As Object, temp As String, lacouleur Dim j As Long Set mondico = CreateObject("Scripting.Dictionary") 'on crée un dictionnaire With Sheets("feuil1") With .Columns("A:K").Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With For j = 1 To 10 Step 3 For i = 2 To .Cells(1, j).End(xlDown).Row 'on parcourt toutes données temp = CStr(.Cells(i, j).Value) If Not mondico.exists(temp) Then mondico.Add temp, .Cells(i, j).Address Else If Not IsNumeric(mondico(temp)) Then ' si ca n'est pas numeric ca veut dire qu'il y a une addresse de cellules puisque lettre et chiffre et le "$" lacouleur = RGB(150 + (Rnd * 255), 150 + (Rnd * 255), 150 + (Rnd * 255)) ' on mixe la lacouleur au hasard Range(mondico(temp)).Interior.Color = lacouleur ' on applique la lacouleur a la cellule dont l'adresse est dans l'item du mondico mondico(temp) = lacouleur ' on remplace l'ancienne adresse dans l'item du mondico par la lacouleur End If .Cells(i, j).Interior.Color = mondico(temp) ' et enfin on applique la lacouleur a l'occurrence en cours avec la lacouleur de l'item mondico correspondant a la valeur de la cellule End If Next i Next j End With Set mondico = Nothing 'on oublie pas de libérer la mémoire End Sub
et en haut du code exCode:plusclair As Integer
et remplacer 150 par "plusclairCode:plusclair = 100'par exemple
Je suis pointilleux, je teste :weird:
Comment eviter si un produit est en double pour que la couleur des cellules soit blanche ? (parfois ça arrive) - C'est un petit détail que je contourne en remettant un produit en double comme ça la couleur de fond blanche change puis je supprime ce rajout de produit afin que les fonds blancs des pdts en double changent de couleurs
Sinon il arrive que 2 pdts en double aient la meme couleur (c'est génant) :oops:
Lorsque je rajoute un produit pour que la liste se remette dans l'ordre alphabetique dans le bac concerné sans que j'ai besoin de relancer Excel afin que cela se fasse, j'ai modifié l'execution comme ceci :
Dans feuil 1
Dans ThisworkbookCode:
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 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Or Target.Column = 4 Or Target.Column = 7 Or Target.Column = 10 Then Doublon End If With ActiveWorkbook.Worksheets("Feuil2").ListObjects("Tableau1").Sort .SortFields. _ Clear .SortFields. _ Add Key:=Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, _ DataOption:=xlSortNormal .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With With Sheets("Feuil1") For i = 1 To 10 Step 3 Set Dcel = .Cells(.Rows.Count, i).End(xlUp) Set Plage = .Range(.Cells(1, i), Dcel(1, 2)) Plage.Sort Key1:=.Cells(1, i), Order1:=xlAscending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Next End With End Sub
Dans module 1Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21 Private Sub Workbook_Open() Sheets("Feuil2").Select Range("Tableau1[[#All],[Colonne1]]").Select Range("A73").Activate ActiveWorkbook.Worksheets("Feuil2").ListObjects("Tableau1").Sort.SortFields. _ Clear ActiveWorkbook.Worksheets("Feuil2").ListObjects("Tableau1").Sort.SortFields. _ Add Key:=Range("Tableau1[Colonne1]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Feuil2").ListObjects("Tableau1").Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Sheets("Feuil1").Select demarrage End Sub
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
40
41
42
43
44
45
46
47
48 Public Dcel As Range, Plage As Range, Cel As Range, i As Long Sub demarrage() Doublon End Sub Sub couleur() 'à toi de voir la valeur de TintAndShade 'à toi de voir les valeurs de y et z Dim y As Long, z As Long y = 5000000 z = 500000 With Sheets("Feuil2") For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row .Range("A" & i).Interior.Color = y .Range("A" & i).Interior.TintAndShade = 0.7 y = y + z Next End With End Sub Sub Doublon() Dim mondico As Object, temp As String, lacouleur Dim j As Long Set mondico = CreateObject("Scripting.Dictionary") 'on crée un dictionnaire With Sheets("feuil1") With .Columns("A:K").Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With For j = 1 To 10 Step 3 For i = 2 To .Cells(1, j).End(xlDown).Row 'on parcourt toutes données temp = CStr(.Cells(i, j).Value) If Not mondico.exists(temp) Then mondico.Add temp, .Cells(i, j).Address Else If Not IsNumeric(mondico(temp)) Then ' si ca n'est pas numeric ca veut dire qu'il y a une addresse de cellules puisque lettre et chiffre et le "$" lacouleur = RGB(150 + (Rnd * 255), 150 + (Rnd * 255), 150 + (Rnd * 255)) ' on mixe la la couleur au hasard Range(mondico(temp)).Interior.Color = lacouleur ' on applique la la couleur a la cellule dont l'adresse est dans l'item du mondico mondico(temp) = lacouleur ' on remplace l'ancienne adresse dans l'item du mondico par la la couleur End If .Cells(i, j).Interior.Color = mondico(temp) ' et enfin on applique la la couleur a l'occurrence en cours avec la la couleur de l'item mondico correspondant a la valeur de la cellule End If Next i Next j End With Set mondico = Nothing 'on oublie pas de libérer la mémoire End Sub
re
tiens teste ca pour tes doublons
le must pour la non monotonie c'est qu'a chaque fois que tu lancera la sub les couleurs changent mais identifie toujours les doublonsCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 Sub Doublon() Randomize Dim mondico As Object, temp As String Dim j As Long, incr As Long Set mondico = CreateObject("Scripting.Dictionary") 'on crée un dictionnaire incr = 3 For j = 1 To 10 Step 3 For i = 2 To Cells(1, j).End(xlDown).Row 'on parcourt toutes données couleur = RGB(255, 255, 255) If Not mondico.exists(Cells(i, j).Value) And Cells(i, j).Value <> "" Then 'si l'ingrédient n'existe pas encore dans le dico c'est qu'on ne l'a jamais croisé donc pas double mondico(Cells(i, j).Value) = "" mondico(Cells(i, j).Value) = Cells(i, j).Address 'on stock l'adresse de la cellule pour la retrouver par la suite Else couleur = Val(RGB(100 + (Rnd * 154), 100 + (Rnd * 154), 100 + (Rnd * 154))) ' on mixe la couleur au hasard Range(mondico(Cells(i, j).Value)).Interior.Color = couleur ' on applique la couleur a la cellule dont l'adresse est dans l'item du dico mondico(Cells(i, j).Value) = couleur ' on remplace l'ancienne adresse dans l'item du dico par la couleur Cells(i, j).Interior.Color = mondico(Cells(i, j).Value) ' et enfin on applique la couleur a l'occurrence en cours avec la couleur de l'item dico correspondant a la valeur de la cellule End If Next i Next j Set mondico = Nothing 'on oublie pas de libérer la mémoire End Sub
c'est fun !!
pas obligé, tu relances la macro, c'est pour ça qu'au début je proposai un bouton de commande sur la feuilleCitation:
C'est un petit détail que je contourne en remettant un produit en double comme ça la couleur de fond blanche change puis je supprime ce rajout de produit afin que les fonds blancs des pdts en double changent de couleurs
à mon avis, la nuance n'est pas visibleCitation:
Sinon il arrive que 2 pdts en double aient la meme couleur (c'est génant)
je viens de t'écrire que tu pouvais supprimer cette macro (si on garde la proposition à Patrick)à Patrick, pas vu ta dernière propositionCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14 Sub couleur() 'à toi de voir la valeur de TintAndShade 'à toi de voir les valeurs de y et z Dim y As Long, z As Long y = 5000000 z = 500000 With Sheets("Feuil2") For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row .Range("A" & i).Interior.Color = y .Range("A" & i).Interior.TintAndShade = 0.7 y = y + z Next End With End Sub
re
pour eviter de tomber sur une couleur blanche c'est tres simple
on supprime quelque possibilités en limitant le rgb (pas 255 partout possible )
comme ca on tombera jamais sur rgb(255,255,255)soit blancCode:couleur = Val(RGB(100 + (Rnd * 134), 100 + (Rnd * 154), 100 + (Rnd * 124))) ' on mixe la couleur au hasard
;)
@ casefayere tu constatera aussi que comme promis j'utilise une seule variable ("couleur") tout le reste se fait par( i,j ) pour les cellule avec le dico
en terme d'allègement je pense pas que l'on puisse faire plus
oui mais du coup ça bug sur la ligne 9 de ton code
Code:couleur = RGB(255, 255, 255)
c'est impossible ca n'a rien a voir
le rgb(255,255,255) est la simplement en cas de non doublons de garder les cellules blanches et en plus c'est avant le changement
peut etre que comme j'ai pas dimer la variable ca plante a cause de ca mais le changement n'a rien a voir
je te joins le fichier qui bug.
Lol!!! la bonne blague
tu a une fonction qui porte le même nom que ma variable couleur hihihihi
supprime la sub couleur elle ne te sert plus a rien
et dim la variable couleur dans doublons
voili voilouCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 Sub Doublon() Randomize Dim mondico As Object, temp As String Dim j As Long, couleur As Long Set mondico = CreateObject("Scripting.Dictionary") 'on crée un dictionnaire incr = 3 For j = 1 To 10 Step 3 For i = 2 To Cells(1, j).End(xlDown).Row 'on parcourt toutes données couleur = RGB(255, 255, 255) If Not mondico.exists(Cells(i, j).Value) And Cells(i, j).Value <> "" Then 'si l'ingrédient n'existe pas encore dans le dico c'est qu'on ne l'a jamais croisé donc pas double mondico(Cells(i, j).Value) = "" mondico(Cells(i, j).Value) = Cells(i, j).Address 'on stock l'adresse de la cellule pour la retrouver par la suite Else couleur = Val(RGB(100 + (Rnd * 134), 100 + (Rnd * 154), 100 + (Rnd * 124))) ' on mixe la couleur au hasard Range(mondico(Cells(i, j).Value)).Interior.Color = couleur ' on applique la couleur a la cellule dont l'adresse est dans l'item du dico mondico(Cells(i, j).Value) = couleur ' on remplace l'ancienne adresse dans l'item du dico par la couleur Cells(i, j).Interior.Color = mondico(Cells(i, j).Value) ' et enfin on applique la couleur a l'occurrence en cours avec la couleur de l'item dico correspondant a la valeur de la cellule End If Next i Next j Set mondico = Nothing 'on oublie pas de libérer la mémoire End Sub
ça bug autre part maintenant.
Rajoute "AIL" dans bac 3 puis supprime le.
1 - la couleur reste
2 - erreur sur la ligne
Code:mondico(Cells(i, j).Value) = couleur ' on remplace l'ancienne adresse dans l'item du dico par la couleur
pour le cas ou il y aurait la même bouftifaille dans tes 4 bacs
on teste si l'item de la cle dico est numerique ou pas car je suppose que ton erreur viens de la
http://www.developpez.net/forums/images/attach/gif.gifCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22 Sub Doublon() Dim mondico As Object, temp As String Dim j As Long, couleur As Long Set mondico = CreateObject("Scripting.Dictionary") 'on crée un dictionnaire For j = 1 To 10 Step 3 For i = 2 To Cells(1, j).End(xlDown).Row 'on parcourt toutes données Randomize couleur = RGB(255, 255, 255) If Not mondico.exists(Cells(i, j).Value) And Cells(i, j).Value <> "" Then 'si l'ingrédient n'existe pas encore dans le dico c'est qu'on ne l'a jamais croisé donc pas double mondico.Add (Cells(i, j).Value), Cells(i, j).Address 'on stock l'adresse de la cellule pour la retrouver par la suite Else If Not IsNumeric(mondico(Cells(i, j).Value)) Then couleur = Val(RGB(100 + (Rnd * 154), 100 + (Rnd * 150), 100 + (Rnd * 144))) ' on mixe la couleur au hasard Range(mondico(Cells(i, j).Value)).Interior.Color = couleur ' on applique la couleur a la cellule dont l'adresse est dans l'item du dico mondico(Cells(i, j).Value) = couleur ' on remplace l'ancienne adresse dans l'item du dico par la couleur End If Cells(i, j).Interior.Color = mondico(Cells(i, j).Value) ' et enfin on applique la couleur a l'occurrence en cours avec la couleur de l'item dico correspondant a la valeur de la cellule End If Next i Next j Set mondico = Nothing 'on oublie pas de libérer la mémoire End Sub
re
ben la bonne blague si tu relance pas la sub doublons après avoir modifier une cellule ca va pas le faire tout seul ca n'est pas une mise en forme conditionnelleCitation:
Rajoute "AIL" dans bac 3 puis supprime le.
1 - la couleur reste
2 - erreur sur la ligne
il faut que tu appelle la sub doublon dans le sheets change
allez il faut tout faire ici hein !!! :ptdr:
ajoute cela dans le module thisworkbook
c'est pas compliqué non d'une pipe en boisCode:
1
2
3 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Name = "Feuil1" And Target.Column Like "[1,4,7,10]" Then Doublon End Sub
as tu essayé de rajouter "Tartiflette" dans bac 3 puis de le supprimer ?
regardes, la couleur reste au lieu de redevenir sans fond coloré car y a plus aucun doublon
Pièce jointe 208802
Si je rajoute un pdt dans bac 3 par exemple mais deja present dans bac 3 (steacks hachés), au lieu qu'Excel le prenne en compte serait il possible d'avoir un msg du style (produit deja present dans ce bac) ?
puré !!
d'apres toi que faudrait -il faire hein!!!???
peut etre ceci
bon allez piece jointe!!Code:
1
2
3 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Name = "Feuil1" And Target.Column Like "[1,4,7,10]" Then Target.Interior.Color = xlNone: Doublon End Sub
le pb reside.
Petit oops de ta part, t'as oublié le code de la feuil1:calim2:
Sinon un grand merci pour ton aide.