Discussion :

[graphikris]

Bonjour,

Je cherche à pouvoir trier dans l'ordre alphabétique 4 colonnes (A, D, G, J) tout en gardant les colonnes (B, E, H, K) en relation avec le tri.
Les colonnes C, F, I séparent les 4 blocs.
Comme vous pouvez le constater, il s'agit d'aliments rangés dans un congélateur. Ces aliments sont dans un tableau sur la feuille 2 et sont dans une liste déroulante sur la feuille 1.
De plus le must serait que si un aliment est en doublon dans un ou plusieurs bacs, il doivent tous être d'une couleur (peut importe laquelle) voir la copie écran.
Quelqu'un pourrait il m'aiguiller ?
J'ai déjà mis dans le Workbook Open, un tri de la feuille 2.

[casefayere]

Bonsoir,
pour ton tri

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub tri()
Dim Dcel As Range, Plage As Range, Cel As Range
Dim i As Long
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 Sub

pour les doublons, je n'ai pas le temps, patience ! ou attends la réponse d'un autre membre

[DeathZarakai]

Je m'insère dans la conversation et j'attendrais la réponse d'un autre.

Pour les doublons, pour ma part j'aurais parcouru 2 fois les listes en incrémentant un Dictionnaire au premier passage.
Est-ce une bonne méthode ou il y a mieux / plus rapide?

Si la solution du dictionnaire est bonne je m'engage à la coder pour graphikris

DeathZarakai.

[graphikris]

@ casefayere : Merci c'est génial, ça fonctionne très bien

@ DeathZarakai : Feu patate

Ci joint le fichier, si ça peut t'aider et eviter que tu le refasses

Merci

[DeathZarakai]

Bon déjà ta macro d'ouverture c'est :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Sheets("Feuill2").Activate

Ensuite en ce qui concerne les doublons, c'est certainement pas la solution la plus élégante mais elle fonctionne en tout cas et est très très rapide d'utilisation.
Pourquoi? On utilise l'objet dictionnaire qui fonctionne sur la même technologie que les bases de données en ce qui concerne la recherche d'un élément (pas une grosse boucle de vérification à chaque fois, on trouve l'élément via sa clé).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Doublon()
    Set mondico = CreateObject("Scripting.Dictionary") 'on crée un dictionnaire
    Dim i As Long, j As Long, incr As Long
    Dim temp As String
 
    incr = 3
 
    With Worksheets("Feuil1")
    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 'si l'ingrédient n'existep as encore dans le dico c'est qu'on ne l'a jamais croisé donc pas double
                mondico.Add temp, .Range(Cells(i, j), Cells(i, j)).Address 'on stock l'adresse de la cellule pour la retrouver par la suite
            Else 'ici on croise un doublon
                If .Range(mondico.Item(temp)).Interior.ColorIndex < 0 Then 'si le fond est non remplit le color index est négatif
                    .Range(mondico.Item(temp)).Interior.ColorIndex = incr  ' donc on ajoute une couleur à la dite cellule et l'ancienne croisée
                    .Cells(i, j).Interior.ColorIndex = incr
                    incr = incr + 1
                Else 'ce passage est pour s'il y a triple ou quadru etc conserver la même couleur
                    .Cells(i, j).Interior.ColorIndex = .Range(mondico.Item(temp)).Interior.ColorIndex
                End If
            End If
        Next i
    Next j
    End With
    Set mondico = Nothing 'on oublie pas de libérer la mémoire
End Sub

DeathZarakai

P.S. : Pour la première remarque j'ai pas inspecté tout le code, juste que c'était la première erreur qui est survenue.

[graphikris]

Je te remercie beaucoup casefayere car ce post pourra également servir pour d'autres idées autres que le congélateur.
Cette idée m'est venue à partir du moment où j'achetais des produits alors qu'ils etaient présents dans mon congel.

[patricktoulon]

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

[casefayere]

Bonjour,

à DeathZarakai

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Sheets("Feuill2").Activate

Pour la première remarque j'ai pas inspecté tout le code, juste que c'était la première erreur qui est survenue.

non, pas obligé si le code est placé sur la feuille avec un bouton de commande(par exemple)

[DeathZarakai]

Merci casefayere, tu m'apprends quelque chose (je me suis auto formé donc normal qu'il me manque des infos ^^) mais pour le coup c'était dans Thisworkbook dans l'instruction Open et cela a généré une erreur, c'est pour ça que je l'ai signalé.

DeathZarakai.

[casefayere]

là, je n'ai plus le temps mais essayerai d'adapter ta proposition au code

[graphikris]

C'est bien la 1ere fois que je vois un duel interessant sur un de mes posts.
Je vous en suis tout reconnaissant.
Merci a vous deux pour votre aide.

[patricktoulon]

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

et puis si t rangeais bien tes aliments au congel, on n'aurait pas besoin de faire cette procédure

toutes les mêmes !!!

[graphikris]

Oui effectivement ce n'est pas un duel mais dans le cas precis un BONDUELLE ! ! !

[casefayere]

mais pour le coup c'était dans Thisworkbook dans l'instruction Open et cela a généré une erreur, c'est pour ça que je l'ai signalé.

perso je n'ai rien mis dedans, travaillant sur fichier indépendant

à DeathZarakai
j'ai parcouru grossièrement et testé ton code pour les couleurs des doublons et j'ai bien aimé, perso, j'étais en route de me faire ch... donc

[casefayere]

C'est bien la 1ere fois que je vois un duel interessant

je préfère le terme "duo"
et puis si t rangeais bien tes aliments au congel, on n'aurait pas besoin de faire cette procédure

[DeathZarakai]

Bah écoute au plaisir.

Je me suis auto formé VBA début Janvier donc je suis toujours en train d'apprendre (pour cela que je viens m'exercer ici). Et depuis que j'ai testé les dico, je suis accro c'est très pratique et tellement plus performant que des boucles de tests.

[casefayere]

Donc par rapport à l'idée d'un bouton sur la feuille, ça pourrait donner ça
le code du bouton appelé "CommandButton1" (au hasard)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub CommandButton1_Click()
tri
End Sub

en tête d'un module

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Option Explicit
Dim i As Long

en-dessous, le tri qui appelera ta macro

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub tri()
Dim Dcel As Range, Plage As Range
 
For i = 1 To 10 Step 3
  Set Dcel = Cells(Rows.Count, i).End(xlUp)
  Set Plage = Range(Cells(2, i), Dcel(1, 2))
  Plage.Sort Key1:=Cells(2, i), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Next
Doublon
End Sub

et ton code, j'ai enlevé le "With" devenu inutile

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Doublon()
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
    temp = CStr(Cells(i, j).Value)
    If Not mondico.Exists(temp) 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 temp, Range(Cells(i, j), Cells(i, j)).Address 'on stock l'adresse de la cellule pour la retrouver par la suite
    Else 'ici on croise un doublon
      If Range(mondico.Item(temp)).Interior.ColorIndex < 0 Then 'si le fond est non rempli le colorindex est négatif
        Range(mondico.Item(temp)).Interior.ColorIndex = incr  ' donc on ajoute une couleur à la dite cellule et l'ancienne croisée
        Cells(i, j).Interior.ColorIndex = incr
        incr = incr + 1
      Else 'ce passage est pour s'il y a triple ou quadru etc conserver la même couleur
        Cells(i, j).Interior.ColorIndex = Range(mondico.Item(temp)).Interior.ColorIndex
      End If
    End If
  Next i
Next j
Set mondico = Nothing 'on oublie pas de libérer la mémoire
End Sub

[graphikris]

Bonjour et merci a vous 2

Je viens de faire un test et il y a des petits soucis.
1 - Si je rajoute par exemple "Ail (sachet ouvert)" dans le bac 3 et que ce meme produit est deja present dans le bac haut, les cellules de ces deux produits se colorient bien mais parfois avec une couleur deja existante d'un autre produit lui aussi en double (ex : Gambas).

2 - Si je supprime un produit en double (donc cellules colorées) la cellule du produit restant reste colorée.

y a t'il une solution a ces deux petits soucis ?

Merci

[casefayere]

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 thisWorkbook

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub Workbook_Open()
demarrage
End Sub

dans le code de Feuil1

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

et le code "doublon" à remplacer par celui-ci (je n'ai pas vu de défaut)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

PS : pour les tests de couleur, tu peux ajouter une variable, ex

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 plusclair As Integer

et en haut du code ex

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

plusclair = 100'par exemple

et remplacer 150 par "plusclair

[graphikris]

Je suis pointilleux, je teste
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)

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 Thisworkbook

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Dans module 1

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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