Ordonner et créer des catégories sous excel

**mouncefdi** · 24/03/2009, 14h18

salut tout le monde,

J'ai créer un tableau avec une macro et je souhaite le mettre en forme.

Avec le code que j’ai, je génère un ensemble de clés à partir de la sheet1 que je mets dans la ligne 2 de la sheet 2, je souhaite ordonner ces clés par catégorie et mettre chaque clé dans un ordre particulier dans sa catégorie , l'orde étant précisé dans une autre sheet nommé Table où on attribue à chaque clé une catégorie et un numéro de colonne particulier.

J’insère avec une macro automatiquement les clès et je souhaite dans un deuxième temps classer ces clès à l’aide d’une autre macro, qu'est ce que je dois faire ?
Ci-joint un exemple de mon tableau (mon tableau en réalité est plus grand que cela et avec une centaine de clés) avec un onglet supplémentaire qui précise la mise en forme que je souhaite avoir.

Le code avec lequel j'insere les clés est le suivant :

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
Sub test12()
    Dim PlageSource As Range
    Dim FeuilleResultat As Worksheet
    Dim NumColonneResultat As Integer
    Dim NumLigneResultat As Integer
    Dim Cell As Range
    Dim Un As Collection
    Dim i As Long
    Dim ValeurX As String
 
    ' nommer tous les endroits sur lesquels on travaille
     Set PlageSource = Worksheets("sheet1").Range("Z:Z")
     Set FeuilleResultat = Worksheets("sheet2")
    NumLigneResultat = 2
 
    ' creer une liste sans doublons, d'après un tutorial de Silkyroad
    Set Un = New Collection
    On Error Resume Next
    'Boucle sur la plage de cellule
    'entre Z et X (-2), et le critère "Main"
    For Each Cell In PlageSource
         ValeurX = Cell.Offset(0, -2).Value
         If (Cell <> "" And ValeurX = "main") Then Un.Add Cell, CStr(Cell)
    Next Cell
    On Error GoTo 0
 
 
    'Boucle sur les éléments de la collection
    'les écrire dans feuille2, en changeant de colonne à chaque fois
    For i = 1 To Un.Count
        FeuilleResultat.Cells(NumLigneResultat, 3 + i) = CStr(Un(i).Value)
    Next i
 
    Set Un = Nothing
End Sub

Si mon problème n'est pas clair je suis prêt à fournir plus d'information.
Vos questions sont les bienvenue!!

A votre disposition

**le petit nicolas** · 28/03/2009, 11h17

salut
je te propose que, au moment d'écrire les clés, tu les écrives en ligne 3. Dans la ligne 1 tu écris la catégorie ("aviation") que tu va chercher dans Table grâce à FIND. dans la ligne 2 tu écris une concaténation de la catégorie et du n° d'ordre ("construction1", "construction2", etc)

puis quand tout sera écrit il te faudra faire un tri selon cette ligne 2 (voir l'enregistreur de macros pour le code). Puis tu supprimes cette ligne 2. Puis tu parcours la ligne 1, pour fusionner les cellules qui ont le même contenu.

PS : je crois que ta question est difficile à comprendre, et le fichier proposé contient une autre macro que celle que tu met dans le post. Tu aurais probablement du continuer le 1er fil de discussion. Peut-etre les modérateurs peuvent-ils déplacer ce fil ?

PS2 : je n'ai pas pu tester ta macro dans le fichier, la méthode "Split" ne marche pas sur Mac.

à +

**mouncefdi** · 28/03/2009, 16h00

Merci le petit Nicolas pour ta réponse, je suis bien conscient que ma question est difficile, d'ailleurs je pense que c'est la principal raison pour laquelle personne n'a intervenu à ce sujet (créé il y a plusieurs jours).

Il me semble que tu as très bien compris le sujet de cette discussion.
Je suis désolé de ne pas avoir fait attention à la macro dans le fichier, j'ai rectifié et je t'ai mis ci-joint le nouveau fichier.

Je t'avoue que je ne suis vraiment pas capable de coder cela....en plus, dans le cas où il y a création d'une nouvelle clés (sheet1 colonne Z) une boite de dialogue devrait s'afficher pour nous demander dans quelle catégorie l'insérer et l'insérer automatiquement en dernière position dans la catégorie....et je ne sais pas comment faire pour cette partie là non plus??

par où je dois commencer (car je suis bien perdu)??qu'est ce que tu en pense en terme de faisabilité ?

Merci d'avance pour vos idées

**mouncefdi** · 30/03/2009, 14h23

Je mettrai la solution en ligne ce soir.....
Merci pour l'aide le petit nicolas.
@+

**le petit nicolas** · 30/03/2009, 23h50

hola, tu as une solution ? ou alors c'était un test.
je suis content de voir que tu as avancé, j'étais en train de travailler à une solution. mais j'esperais aussi un peu que tu essayes de ton côté, le but du forum étant de fournir une aide mais pas de sous-traiter le travail...

donc ma soluce :

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
 
Sub test12()
    Dim PlageSource As Range
    Dim FeuilleResultat As Worksheet
    Dim NumColonneResultat As Integer
    Dim NumLigneResultat As Integer
    Dim Cell As Range
    Dim Un As Collection
    Dim i As Long
    Dim ValeurX As String
 
    Dim manquants As Collection
    Dim CellResultRecherche As Range
    Dim MaCle As String
    Dim FeuilleTable As Worksheet
    Dim NumLigneCategorie As Integer
    Dim NumLigneNumOrdre As Integer
    Dim categorie As String
    Dim PlageTri As Range
    Dim CellCategorie As Range
 
    ' nommer tous les endroits sur lesquels on travaille
    Set PlageSource = Worksheets("sheet1").Range("Z:Z")
    Set FeuilleResultat = Worksheets("sheet2")
    Set FeuilleTable = Worksheets("Table")
    Set PlageRecherche = FeuilleTable.Range("A:A")
    NumColCategorie = 2
    NumColNumOrdre = 3
    NumLigneResultat = 2
 
    ' creer une liste sans doublons, d'après un tutorial de Silkyroad
    Set Un = New Collection
    Set manquants = New Collection
    On Error Resume Next
    'Boucle sur la plage de cellule
    'entre Z et X (-2), et le critère "Main"
    For Each Cell In PlageSource
         ValeurX = Cell.Offset(0, -2).Value
         If (Cell <> "" And ValeurX = "main") Then
            MaCle = CStr(Cell)
            Un.Add Cell, MaCle
            Set CellResultRecherche = PlageRecherche.Find(What:=MaCle, LookAt:=xlPart, MatchCase:=False)
            If CellResultRecherche Is Nothing Then
                manquants.Add Cell, MaCle
                PlageRecherche.Cells(PlageRecherche.Rows(PlageRecherche.Rows.Count).End(xlUp).Row + 1, 1) = MaCle
            End If
        End If
    Next Cell
    On Error GoTo 0
 
    If manquants.Count > 0 Then
        MsgBox ("veuillez renseigner les catégories vides dans la feuille 'Table'")
        PlageRecherche.Parent.Activate
        GoTo Fin
    End If
 
    FeuilleResultat.Rows(NumLigneResultat - 1).Insert Shift:=xlDown
    NumLigneResultat = NumLigneResultat + 1
    Set PlageTri = FeuilleResultat.Range(Cells(NumLigneResultat - 2, 4), Cells(NumLigneResultat, 3 + Un.Count))
    FeuilleResultat.Rows(NumLigneResultat - 2).UnMerge
    Range(PlageTri, Cells(NumLigneResultat, 3).End(xlToRight)).ClearContents
 
    'Boucle sur les éléments de la collection
    'les écrire dans feuille2, en changeant de colonne à chaque fois
 
    For i = 1 To Un.Count
        MaCle = CStr(Un(i).Value)
        On Error Resume Next
        Set CellResultRecherche = PlageRecherche.Find(What:=MaCle, LookAt:=xlPart, MatchCase:=False)
        If Not (CellResultRecherche Is Nothing) Then
            categorie = FeuilleTable.Cells(CellResultRecherche.Row, NumColCategorie).Value
            FeuilleResultat.Cells(NumLigneResultat - 2, 3 + i).Value = categorie
            FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i).Value = categorie & FeuilleTable.Cells(CellResultRecherche.Row, NumColNumOrdre).Value
            FeuilleResultat.Cells(NumLigneResultat, 3 + i).Value = MaCle
        Else
            MsgBox ("clé absente dans la feuille 'Table'")
            PlageRecherche.Parent.Activate
            GoTo Fin
        End If
    Next i
 
    PlageTri.Sort Key1:=FeuilleResultat.Rows(NumLigneResultat - 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
    FeuilleResultat.Rows(NumLigneResultat - 1).Delete
    NumLigneResultat = NumLigneResultat - 1
 
    For i = 1 To Un.Count
        Set CellCategorie = FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i)
        CategorieValue = CellCategorie.Value
        While (CategorieValue = FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i + 1).Value)
            i = i + 1
            If i > Un.Count Then Exit For
        Wend
        Range(CellCategorie, FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i)).ClearContents
        Range(CellCategorie, FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i)).Merge
        Range(CellCategorie, FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i)).Value = CategorieValue
        On Error GoTo 0
    Next i
 
Fin:
        Set Un = Nothing
        Set manquants = Nothing
        Exit Sub
End Sub

**mouncefdi** · 31/03/2009, 10h43

salut le petit nicolas, merci pour ta réponse.
afin d'ordonner les clés, j'integre dans mon code un "Sort de la colonne C de la table" et j'utilise un find par la suite, ceci me permet d'éviter les concaténations.
Je suis en train d'essayer ton code, il est mieux que le mien et si j'ai bien compris il compare les clés existentes de la sheet1 avec les clés existentes dans la "table", le cas échéant il demande de renseigner la catégorie dans la sheet "table"....ce qui est génial!!!
Une fois que j'aurais paufiner mon code en m'appuyant sur tes conseils et ton code, je le mettrais en ligne à la disposition des autres internautes...

Pour l'instant il y a un problème au niveau de :

Code :

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

Set PlageTri = FeuilleResultat.Range(Cells(NumLigneResultat - 2, 4), Cells(NumLigneResultat, 3 + Un.Count))

En clair, les clès ne sont pas générées dans l'ordre précisé dans la Table??
Il me semble qu'il y a un vrai problème au niveau des concaténations selon lesquelles on met en ordre les clès par la suite, pourtant au niveau du code tout me parait logique....

**le petit nicolas** · 31/03/2009, 19h10

En clair, les clès ne sont pas générées dans l'ordre précisé dans la Table??
Il me semble qu'il y a un vrai problème au niveau des concaténations selon lesquelles on met en ordre les clès par la suite, pourtant au niveau du code tout me parait logique...

effectivement, il y a un bug. Mea culpa, j'avais mal testé, la faute sans doute au marchand de sable. donc correction de ces lignes autour de Set PlageTri :

Code :

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

1
2
3
4
5
    FeuilleResultat.Rows(NumLigneResultat - 1).UnMerge
    FeuilleResultat.Rows(NumLigneResultat - 1).Insert Shift:=xlDown
    NumLigneResultat = NumLigneResultat + 1
    Set PlageTri = FeuilleResultat.Range(Cells(NumLigneResultat - 2, 4), Cells(NumLigneResultat, 3 + Un.Count))
    Range(PlageTri, Cells(NumLigneResultat, 3).End(xlToRight)).ClearContents

j'espère que ca marche mieux comme ca...

Bonus : mise en forme
Tu peux rajouter ça à la fin de la macro (avant le Tag "Fin:"). Ca peaufine :

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
    With PlageTri
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
    End With
    PlageTri.Rows(1).HorizontalAlignment = xlCenter

**mouncefdi** · 31/03/2009, 19h11

Salut le petit Nicolas et forum,

Finalement je ne vois pas vraiment comment tu tri les clés?
J'ai pas l'impression que PlageTri.Sort marche....???

Le code que j'ai mis en place est rudimentaire, il cherche les catégories que je définis dans mon code ( et qui normalement ne vont pas changer) et récupère les clès de la table.
Ton code est mille fois mieux, car il est plus généraliste est permet de récupérer tous les éléments et de comparer la sheet et la table, par contre j'ai pas compris la partie dans ton code où tu fais le sort sur la plageTri...

Est ce tu pourras m'expliquer la démarche stp?

**le petit nicolas** · 31/03/2009, 19h15

le tri se fait bien par PlageTri.sort

mais c'était le UnMerge qui était mal placé, ce qui faisait que Petrole1, Petrole 2,... ne s'écrivaient pas bien. Le tri se fait sur cette ligne temporaire (ajoutée par Add puis supprimée par Delete) donc ca ne marchait pas bien.

la correction que j'ai postée en même temps que ta question doit résoudre le pb

**mouncefdi** · 31/03/2009, 19h18

Mon code est le suivant :

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
Sub mise_enforme_clefs()
    Dim PlageSource As Range
    Dim FeuilleResultat As Worksheet
    Dim NumColonneResultat As Integer
    Dim NumLigneResultat As Integer
    Dim Cell As Range
    Dim Un As Collection
    Dim Un1 As Collection
    Dim Un2 As Collection
    Dim i As Long
    Dim j As Long
    Dim ValeurD As String
    Sheets("table").Select
    Cells.Select
    Range("E1").Activate
    Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("H1").Select
    Sheets("table").Select
        Cells.Find(What:="Scn", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("sheet1").Select
    Range("E1").Select
    ActiveSheet.Paste
 
    ' nommer tous les endroits sur lesquels on travaille
     Set PlageSource = Worksheets("table").Range("B:B")
     Set FeuilleResultat = Worksheets("sheet1")
     NumLigneResultat = 2
 
    ' creer une liste sans doublons
    Set Un = New Collection
    On Error Resume Next
    'Boucle sur la plage de cellule
    'entre D et E (2), et le critère "Scn"
    For Each Cell In PlageSource
         ValeurD = Cell.Offset(0, 2).Value
         If (Cell <> "" And ValeurD = "Scn") Then Un.Add Cell, CStr(Cell)
    Next Cell
    On Error GoTo 0
 
    'Boucle sur les éléments de la collection
    For i = 1 To Un.Count
        FeuilleResultat.Cells(NumLigneResultat, 4 + i) = CStr(Un(i).Value)
    Next i
 
    Sheets("table").Select
        Cells.Find(What:="Nomi", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("sheet1").Select
    Sheets("sheet1").Cells(1, 4 + i).Select
    ActiveSheet.Paste
    Set PlageSource = Worksheets("table").Range("B:B")
    Set FeuilleResultat = Worksheets("sheet1")
    NumLigneResultat = 2
    ' creer une liste sans doublons
    Set Un1 = New Collection
    On Error Resume Next
    'Boucle sur la plage de cellule
    'entre D et E (2), et le critère "sheet1"
    For Each Cell In PlageSource
         ValeurD = Cell.Offset(0, 2).Value
         If (Cell <> "" And ValeurD = "Nomi") Then Un1.Add Cell, CStr(Cell)
    Next Cell
    On Error GoTo 0
    For i = 5 + Un.Count To 4 + Un.Count + Un1.Count
        FeuilleResultat.Cells(NumLigneResultat, i) = CStr(Un1(i - 4 - Un.Count).Value)
 
      Next i
 
      Sheets("table").Select
        Cells.Find(What:="Scen", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("sheet1").Select
    Sheets("sheet1").Cells(1, i).Select
    ActiveSheet.Paste
    Set PlageSource = Worksheets("table").Range("B:B")
     Set FeuilleResultat = Worksheets("sheet1")
    NumLigneResultat = 2
    ' creer une liste sans doublons
    Set Un2 = New Collection
    On Error Resume Next
    'Boucle sur la plage de cellule
    'entre D et E (2), et le critère "sheet1"
    For Each Cell In PlageSource
         ValeurD = Cell.Offset(0, 2).Value
         If (Cell <> "" And ValeurD = "Scen") Then Un2.Add Cell, CStr(Cell)
    Next Cell
    On Error GoTo 0
    For i = 5 + Un.Count + Un1.Count To 4 + Un.Count + Un1.Count + Un2.Count
        FeuilleResultat.Cells(NumLigneResultat, i) = CStr(Un2(i - 4 - Un.Count - Un1.Count).Value)
 
      Next i
 
    Sheets("table").Select
    Cells.Select
    Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Range("H1").Select
End Sub

Je ne comprends pas le problème persiste? toujours au niveau de

Code :

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

Set PlageTri = FeuilleResultat.Range(Cells(NumLigneResultat - 2, 4), Cells(NumLigneResultat, 3 + Un.Count))

ca doit etre surement à cause de la ligne temporaire...
en tout cas merci beaucoup pour l'aide, ton code est génial!!!

**le petit nicolas** · 31/03/2009, 19h54

qu'est-ce qui apparait comme pb à cette ligne ? un message d'erreur ? chez moi ca marche (sur un mac en plus !). ou alors j'ai mal compris ta demande, le résultat ne correspond pas à ce que tu veux ?

ah ben j'avais pas vu ton code de 19h39, à priori tu as du arriver à une solution qui te convient...

**mouncefdi** · 01/04/2009, 11h19

Bonjour le petit Nicolas,

J'ai regardé le code de plus près, et effectivement il y a un problème au niveau de l'ordre d'insertion des clès du au fait que le "Sort" sur la ligne 2 où il y a les concaténations ne classe pas les concaténations dans l'ordre :
Telecom1 Telecom2 Telecom3 Telecom4......( ceci est valable pour moi car j'ai une centaine de clès dont approximativement 30 par catégorie)

La partie du code où il y a un problème est la suivante :

Code :

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

1
2
3
PlageTri.Sort Key1:=FeuilleResultat.Rows(NumLigneResultat - 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
    FeuilleResultat.Rows(NumLigneResultat - 1).Delete
    NumLigneResultat = NumLigneResultat - 1

En clair, je pense que Excel ne comprend pas le Sort sur notre ligne 2...

**le petit nicolas** · 01/04/2009, 13h08

salut,

est-ce que ca trie Telecom1, Telecom11, ..., Telecom2,... ?

si oui, il faut mettre la concaténation de manière à ce que ca fasse Telecom0001, Telecom0002, etc

Code :

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

1
2
3
4
5
'c'est la ligne
            FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i).Value = categorie & FeuilleTable.Cells(CellResultRecherche.Row, NumColNumOrdre).Value
 
'qu'il faut remplacer par 
            FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i).Value = categorie & CStr(Format(FeuilleTable.Cells(CellResultRecherche.Row, NumColNumOrdre).Value, "0000"))

**mouncefdi** · 01/04/2009, 14h24

salut,

Non pas du tout, et j'ai fais aussi un sort manuelle sur la colonne number, après j'ai lancé la macro mais ca ne marche pas non plus

Je reste dessus toute cet après midi pour explorer d'autres pistes

**le petit nicolas** · 01/04/2009, 18h47

vraiment je ne vois pas, chez moi ça marche au poil de loche...
je joins mon fichier

**mouncefdi** · 01/04/2009, 19h40

Je ne sais pas non plus
en fait dans ma vrai table,
j'ai les clefs sur la colonne B
la catégorie sur la colonne D
et le Number sur la colonne E

J'ai changé dans le code les numéro de colonne...
Si ca se trouve, ca vient d'ici?? (j'ai du peut etre oublier de changer quelquechose)

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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Sub testf()
    Dim PlageSource As Range
    Dim FeuilleResultat As Worksheet
    Dim NumColonneResultat As Integer
    Dim NumLigneResultat As Integer
    Dim Cell As Range
    Dim Un As Collection
    Dim i As Long
    Dim ValeurX As String
 
    Dim manquants As Collection
    Dim CellResultRecherche As Range
    Dim MaCle As String
    Dim FeuilleTable As Worksheet
    Dim NumLigneCategorie As Integer
    Dim NumLigneNumOrdre As Integer
    Dim categorie As String
    Dim PlageTri As Range
    Dim CellCategorie As Range
 
    ' nommer tous les endroits sur lesquels on travaille
    Set PlageSource = Worksheets("sheet1").Range("Z:Z")
    Set FeuilleResultat = Worksheets("new")
    Set FeuilleTable = Worksheets("table")
    Set PlageRecherche = FeuilleTable.Range("B:B")
    NumColCategorie = 4
    NumColNumOrdre = 5
    NumLigneResultat = 2
 
    ' creer une liste sans doublons, d'après un tutorial de Silkyroad
    Set Un = New Collection
    Set manquants = New Collection
    On Error Resume Next
    'Boucle sur la plage de cellule
    'entre Z et X (-2), et le critère "Main"
    For Each Cell In PlageSource
         ValeurX = Cell.Offset(0, -2).Value
         If (Cell <> "" And ValeurX = "main") Then
            MaCle = CStr(Cell)
            Un.Add Cell, MaCle
            Set CellResultRecherche = PlageRecherche.Find(What:=MaCle, LookAt:=xlPart, MatchCase:=False)
            If CellResultRecherche Is Nothing Then
                manquants.Add Cell, MaCle
                PlageRecherche.Cells(PlageRecherche.Rows(PlageRecherche.Rows.Count).End(xlUp).Row + 1, 1) = MaCle
            End If
        End If
    Next Cell
    On Error GoTo 0
 
    If manquants.Count > 0 Then
        MsgBox ("veuillez renseigner les Types de clés dans la feuille 'table'")
        PlageRecherche.Parent.Activate
        GoTo Fin
    End If
 
    FeuilleResultat.Rows(NumLigneResultat - 1).UnMerge
    FeuilleResultat.Rows(NumLigneResultat - 1).Insert Shift:=xlDown
    NumLigneResultat = NumLigneResultat + 1
    Set PlageTri = FeuilleResultat.Range(Cells(NumLigneResultat - 2, 4), Cells(NumLigneResultat, 3 + Un.Count))
    Range(PlageTri, Cells(NumLigneResultat, 3).End(xlToRight)).ClearContents
 
    'Boucle sur les éléments de la collection
    'les écrire dans feuille2, en changeant de colonne à chaque fois
 
    For i = 1 To Un.Count
        MaCle = CStr(Un(i).Value)
        On Error Resume Next
        Set CellResultRecherche = PlageRecherche.Find(What:=MaCle, LookAt:=xlPart, MatchCase:=False)
        If Not (CellResultRecherche Is Nothing) Then
            categorie = FeuilleTable.Cells(CellResultRecherche.Row, NumColCategorie).Value
            FeuilleResultat.Cells(NumLigneResultat - 2, 3 + i).Value = categorie
            FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i).Value = categorie & FeuilleTable.Cells(CellResultRecherche.Row, NumColNumOrdre).Value
            FeuilleResultat.Cells(NumLigneResultat, 3 + i).Value = MaCle
        Else
            MsgBox ("clé absente dans la feuille 'Table'")
            PlageRecherche.Parent.Activate
            GoTo Fin
        End If
    Next i
 
    PlageTri.Sort Key1:=FeuilleResultat.Rows(NumLigneResultat - 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
    FeuilleResultat.Rows(NumLigneResultat - 1).Delete
    NumLigneResultat = NumLigneResultat - 1
 
    For i = 1 To Un.Count
        Set CellCategorie = FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i)
        CategorieValue = CellCategorie.Value
        While (CategorieValue = FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i + 1).Value)
            i = i + 1
            If i > Un.Count Then Exit For
        Wend
        Range(CellCategorie, FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i)).ClearContents
        Range(CellCategorie, FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i)).Merge
        Range(CellCategorie, FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i)).Value = CategorieValue
        On Error GoTo 0
    Next i
 
Fin:
        Set Un = Nothing
        Set manquants = Nothing
        Exit Sub
End Sub

Je viens d'ouvrir ton fichier, j'ai executer le code mais ca bug au niveau de

Code :

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

Set PlageTri = FeuilleResultat.Range(Cells(NumLigneResultat - 2, 4), Cells(NumLigneResultat, 3 + Un.Count))

Je vais continuer a voir ca ce soir, en espérant voir où il y a le pbm...

**le petit nicolas** · 01/04/2009, 23h18

j'ai mis Option Explicit (au cas ou confuse de variable, mais non), et décalé les colonnes dans Table. J'ai changé les noms des feuilles. J'ai testé. La 1ere fois Pb sur la ligne Set PlageTri, j'ai continué l'exécution (touche F8) et ça a continué sans pb. Les fois suivantes plus de pb

bon ben on est deux à n'y plus rien comprendre, alors

**mouncefdi** · 02/04/2009, 18h59

Salut le petit Nicolas,

Pour le bug sur la ligne Set PlageTri, il faut juste etre placer sur la feuille où l'on souhaite insérer les clès pour que ca marche (je pense qu'avec sheet.activate dans le code ca devrait marcher)

Pour le "Sort" ça marche bien, tu avais d'ailleurs raison hier :

Code :

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

1
2
3
4
5
'c'est la ligne
            FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i).Value = categorie & FeuilleTable.Cells(CellResultRecherche.Row, NumColNumOrdre).Value
 
'qu'il faut remplacer par 
            FeuilleResultat.Cells(NumLigneResultat - 1, 3 + i).Value = categorie & CStr(Format(FeuilleTable.Cells(CellResultRecherche.Row, NumColNumOrdre).Value, "0000"))

J'ai passé toute la journée sur le code, et je viens de trouver le souci au niveau du code :

En fait le code ne m'insère pas toutes les clès, il en saute quelques unes :
exemple :Telecom 40 Telecom 43 Telecom 44 Telecom 46
Le problème est du à l'utilisation du : On Error Resume Next dans le code.
(dès qu'il trouve une erreur il passe à autre chose et il doit me rater une clè sur ma table à ce moment là)
J'ai mis le On Error Resume Next en commentaire, et le message suivant s'affiche :

Run-time error ‘457’
This Key is already associated with an element of this collection
Je ne sais pas comment debugger ca, mais en tout cas le problème provient surement d'ici, il me semble qu'il faut traiter l'erreur de facon + spécifique ( et non pas de facon générale comme c'est le cas ici avec le On Error Resume Next )
Le message d'erreur me laisse penser aussi à une histoire de doublons dans les clès.............
Enfin je sais pas encore comment il faut procéder....Mais le pbm à l'air d'être de taille

**le petit nicolas** · 02/04/2009, 19h29

en regardant bien, il y a 2 fois On Error Resume Next

le 1er lors de la construction de la collection. La Key doit etre unique, c'est sur ce principe que se base la construction d'une collection sans doublons. je crois que ce Resume Next, il faut le laisser. C'était bien un besoin de base, de supprimer les doublons ?

Il peut y avoir un souci si la Key accepte un nombre limité de caractères : la clé est différente mais la Key tronquée sera la même. J'ai regardé dans l'aide, je n'ai pas trouvé de limite de taille pour Key, mais peut-être y en a t'il une ?

2ème Resume Next un peu plus loin, au moment d'écrire dans la feuille résultat (For i = 1 to Un.count), qui effectivement ne sert à rien, comme le On Error Goto 0 qui est un peu plus loin. Ces lignes sont des séquelles des phases intermédiaires de conception, on peut (doit) les supprimer.

**mouncefdi** · 02/04/2009, 19h57

salut le petit nicolas,

oui éliminer les doublons est une nécessité...
Je ne pense pas que ça soit un problème lié à aux nbre de caractères dans les clés....
enfin je ne sais plus rien, en tout cas c'est après l'insertion des nouvelle clés ds la table que le pbm apparait....
Je pense que je vais passer encore un long moment sur ce code....

Je te remercie pour les précisions....

dsl je pense que j'ai du t'envoyer le même msg en private (c'est la fatigue)

Ordonner et créer des catégories sous excel

Macros et VBA Excel

Discussions similaires

Partager

Partager