Discussion :

[Dubbleu]

Au temps pour moi. ca marche sur les versions partielles. je te mets la version complete de l'EXCEL du coup

Ton code est dans le module 6

Merci d'avance

[Daniel.C]

A partir de E21, il y a des cellules fusionnées avec des références différentes.

[Dubbleu]

Oui oui je sait, il y a la maccro SC qui permet de ne garde que la première reférence. mais meme après après avoir fait tourner cette macro, j'ai toujours l'erreur 437

[Daniel.C]

Si le résultat te satisfait, utilise :

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
Sub Recap()
    Dim C As Range, F, Dico As Object, Tabl1() As String, Tabl2() As Integer
    Dim Res As String, Txt, Ligne As Long, Ctr As Long
    Set Dico = CreateObject("Scripting.Dictionary")
    Ligne = 1
    With Sheets("Feuil1")
        ReDim Tabl1(Application.CountA(.[E:E]) - 2)
        ReDim Tabl2(Application.CountA(.[E:E]) - 2, 2)
        Ctr = -1
        For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
            If .Cells(i, 5) <> "" Then
                Ctr = Ctr + 1
                Tabl1(Ctr) = .Cells(i, 5)
            End If
        Next i
        F = Array("Feuil3", "Feuil4", "Feuil5")
        .[E2:E65000].Clear
        .[R2:T65000].Clear
    End With
    For i = 0 To 2
        With Sheets(F(i))
            For Each C In .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
                If C.Offset(, -1) <> "" Then
                    Res = C.Offset(, -1)
                End If
                If Not Dico.exists(Res & "***" & i + 1 & "***" & C.Value) Then
                    Dico.Add Res & "***" & i + 1 & "***" & C.Value, Res & "***" & i + 1 & "***" & C.Value
                End If
            Next C
        End With
    Next i
    With Sheets("Feuil1")
        For Each Item In Dico.items
            Txt = Split(Item, "***")
            lig = Application.Match(Txt(0), Tabl1, 0) - 1
            Tabl2(lig, CInt(Txt(1)) - 1) = Tabl2(lig, CInt(Txt(1)) - 1) + 1
        Next Item
        For i = 0 To UBound(Tabl1)
            lig = 0
            For x = 0 To UBound(Tabl2, 2)
                If Tabl2(i, x) > lig Then lig = Tabl2(i, x)
            Next x
            For x = 1 To lig
                Ligne = Ligne + 1
                .Cells(Ligne, 5) = Tabl1(i)
            Next x
        Next i
        For Each Item In Dico.items
            For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
                Txt = Split(Item, "***")
                If .Cells(i, 5) = Txt(0) And .Cells(i, 17).Offset(, CInt(Txt(1))) = "" Then
                    .Cells(i, 17).Offset(, CInt(Txt(1))) = Txt(2)
                    Exit For
                End If
            Next i
        Next Item
        With .[E1].CurrentRegion
            .Borders.LineStyle = xlContinuous
            .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        End With
        With .[E1].CurrentRegion.Offset(, 13).Resize(, 3)
            .Borders.LineStyle = xlContinuous
            .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        End With
        Res = "E2"
        Application.DisplayAlerts = False
        For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
            If .Cells(i, 5) <> .Range(Res) Then
                .Range(.Cells(i, 5).Offset(-1), Range(Res)).Merge
                Res = .Cells(i, 5).Address
            End If
            If i = .Cells(.Rows.Count, 5).End(xlUp).Row Then
                .Range(.Cells(i, 5), Range(Res)).Merge
            End If
        Next i
        .Range(.[E2], .Cells(.Rows.Count, 5).End(xlUp)).VerticalAlignment = xlCenter
        Application.DisplayAlerts = True
    End With
End Sub

[Dubbleu]

Voila mon petit problème

En feuille 1 il y a ce que j'ai actuellement
en feuille 1 (2) ce que je souhaiterais

Après tout tourne impeccablement c'est juste ce petit detail qui me génère un décalage. j'ai essayé en insérent un if mais ca n'a pas marché....

Merci d'avance

[Daniel.C]

La seule différence que je voie, c'est la ligne "Réf1" vide. Comment est-ce que je sais qu'elle existe ? est-e que Réf1... Réf9 est une suite sans interruption ? ou est-ce que j'ai manqué quelque chose ? S'il y a "Réf10" sans produit, je n'ai aucun moyen de le savoir.

[Dubbleu]

ce sont des référence qui ne se suivent pas forcement. mais elle sont toute dans la colonne E de la feuille 1.
Je souhaiterais conserver les référence de la feuilles 1; Le soucis que j'ai actuellement c'est que la maccro n'affiche pas la reférence de la feuille 1 si il n'y pas pas de produit associé en feuil3 4 5. du coup comme j'ai d'autre données sur ma feuille 1. ca fausse mon tableau.

[Daniel.C]

Si je me souviens bien, ce classeur correspond au résultat après exécution de la macro. Peux-tu me donner le classeur avant exécution ?

[Dubbleu]

voila le classeur avant execution.
Dans la feuil1 (2) j'ai mis ce qu'il faudra que j'obtienne
Dans la feuil1 il suffit d'execter la macro

J'ai rajouté la colonne blabla pour plus de clarté (dans mon classeur réel je n'ai rien en colonne U mais j'ai du "blabla" en colonne A à D et F à Q....

Dis moi si je suis assez explicite et si tu pense qu'il y a un moyen

[Daniel.C]

Je commence juste à m'y mettre. Obligé de commenter le code pour me rappeler ce que j'ai fait. Tu auras, sauf gros ennui, un résultat avant dimanche soir.

J'ai rajouté la colonne blabla pour plus de clarté (dans mon classeur réel je n'ai rien en colonne U mais j'ai du "blabla" en colonne A à D et F à Q....

Et qu'est-ce que je dois faire ? Si c'est la même chose que la colonne U, j'ai besoin de savoir exactement quelles colonnes concernées, pas des points de suspension.

Voici la macro compte non tenu du blabla (voir mon post ci-dessus).

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
Sub Recap()
    Dim C As Range, F, Dico As Object, Tabl1() As String, Tabl2() As Integer
    Dim Res As String, Txt, Ligne As Long, Ctr As Long
    Set Dico = CreateObject("Scripting.Dictionary")
    Ligne = 1
    With Sheets("Feuil1")
        ReDim Tabl1(Application.CountA(.[E:E]) - 2)
        ReDim Tabl2(Application.CountA(.[E:E]) - 2, 2)
        Ctr = -1
        'remplissage de Tabl1 avec les valeurs de la colonne E
        For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
            If .Cells(i, 5) <> "" Then
                Ctr = Ctr + 1
                Tabl1(Ctr) = .Cells(i, 5)
            End If
        Next i
        F = Array("Feuil3", "Feuil4", "Feuil5")
        'Effacement des colonnes E, R:T
'        For i = 0 To UBound(Tabl1)
'            Dico.Add Tabl1(i), Tabl1(i)
'        Next i
        .[E2:E65000].Clear
        .[R2:T65000].Clear
    End With
    For i = 0 To 2
        'boucle sur les feuilles
        With Sheets(F(i))
            'boucle sur les cellules de la colonne B
            For Each C In .Range(.[B2], .Cells(.Rows.Count, 2).End(xlUp))
                'si la cellule de la colonne A n'est pas vide
                If C.Offset(, -1) <> "" Then
                    'on met cette valeur dans "Res"
                    Res = C.Offset(, -1)
                End If
                'si elle n'existe pas, on crée une entrée dans le dictiionnaire avec Res, l'index de la feuille et le produit
                If Not Dico.exists(Res & "***" & "***" & i + 1 & "***" & C.Value) Then
                    Dico.Add Res & "***" & i + 1 & "***" & C.Value, Res & "***" & i + 1 & "***" & C.Value
                End If
            Next C
        End With
    Next i
    With Sheets("Feuil1")
        'boucle sur les éléments du dictionnaire
        For Each Item In Dico.items
            Txt = Split(Item, "***")
            'position de l'élément dans Table1
            lig = Application.Match(Txt(0), Tabl1, 0) - 1
                'incrémentation dans le compteur correspondant à la feuille
                Tabl2(lig, CInt(Txt(1)) - 1) = Tabl2(lig, CInt(Txt(1)) - 1) + 1
        Next Item
        'boucle sur la table des références
        For i = 0 To UBound(Tabl1)
            lig = 0
            For x = 0 To UBound(Tabl2, 2)
                If Tabl2(i, x) > lig Then lig = Tabl2(i, x)
            Next x
            For x = 1 To lig
                Ligne = Ligne + 1
                .Cells(Ligne, 5) = Tabl1(i)
            Next x
        Next i
        For Each Item In Dico.items
            For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
                Txt = Split(Item, "***")
                If .Cells(i, 5) = Txt(0) And .Cells(i, 17).Offset(, CInt(Txt(1))) = "" Then
                    .Cells(i, 17).Offset(, CInt(Txt(1))) = Txt(2)
                    Exit For
                End If
            Next i
        Next Item
        'incorporation des références sans produit
        For i = 0 To UBound(Tabl1)
            If Not IsNumeric(Application.Match(Tabl1(i), .[A:A], 0)) Then
                Ligne = .Cells(.Rows.Count, 5).End(xlUp).Row + 1
                .Cells(Ligne, 5) = Tabl1(i)
            End If
        Next i
        .[AA:DD].Clear
        Ligne = .Cells(.Rows.Count, 5).End(xlUp).Row
        .Range(.[E2], .Cells(Ligne, 5)).Copy .[AA1]
        .Range(.[R2], .Cells(Ligne, "R")).Resize(, 3).Copy .[AB1]
        .Range(.[AA1], .Cells(.Rows.Count, "AA").End(xlUp)).Resize(, 4).Sort .[AA1], xlAscending, Header:=xlNo
        .Range(.[AA1], .Cells(Ligne, "AA")).Copy .[E2]
        .Range(.[AB1], .Cells(Ligne, "AB")).Resize(, 3).Copy .[R2]
        .[AA:DD].Clear
        With .[E1].CurrentRegion
            .Borders.LineStyle = xlContinuous
            .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        End With
        With .[E1].CurrentRegion.Offset(, 13).Resize(, 3)
            .Borders.LineStyle = xlContinuous
            .BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
        End With
        Res = "E2"
        Application.DisplayAlerts = False
        For i = 2 To .Cells(.Rows.Count, 5).End(xlUp).Row
            If .Cells(i, 5) <> .Range(Res) Then
                .Range(.Cells(i, 5).Offset(-1), Range(Res)).Merge
                Res = .Cells(i, 5).Address
            End If
            If i = .Cells(.Rows.Count, 5).End(xlUp).Row Then
                .Range(.Cells(i, 5), Range(Res)).Merge
            End If
        Next i
        .Range(.[E2], .Cells(.Rows.Count, 5).End(xlUp)).VerticalAlignment = xlCenter
        Application.DisplayAlerts = True
    End With
End Sub

[Dubbleu]

Bonjour Daniel,
je suis désolé de ne pas avoir pu te répondre plus tôt; j''ai oublié mon alim d'ordi et je viens tout juste de la récupérer.

En gros ce que je te disais, c'est que j'ai du texte qui correspond a chaque reférence dans les colonnes A à D et F à Q. Actuellement ca décale les référence et du coup les références ne sont plus en concordance avec le texte.

Je te mets en pièce jointe l'excel original ca sera plus clair. ne tient pas compte des feuilles (Données, tools hors MPD, consommables hors MPD et revisables hors MPD)
La dernière version de la macro que tu m'a fournie est dans le module 9 mais malheureusement elle génère toujours un décalage de ligne....

[Daniel.C]

Bonjour,

La dernière version de la macro que tu m'a fournie est dans le module 9 mais malheureusement elle génère toujours un décalage de ligne....

Il est où, le décalage dans le classeur du 12/07 ?

[Dubbleu]

sur le classeur du 12/07 lorsque tu lance la macro récap. la ligne ref1 est supprimé du coup blabla1 est associé 0 ref2 et non à ref1

[Daniel.C]

Si tu as exécuté la dernière macro, tu verras que "Réf1" n'est pas supprimé. Par contre les références sont triées, c'est à dire qu'on trouve la séquence normale des valeurs triées (Réf1, Réf10, Réf11...). Comme indiqué, je n'ai traité les "blabla" fautes de précisions suffisantes.

[Dubbleu]

j'ai vu oui. le soucis c'est que les références sont totalement dissociées des autres données de la ligne initiale. Du coup après execution de la macros, mon classeur est completement faussé. je pense que je vais finir par laisser tomber.... Je n'arrive à rien de mon coté et je te fais perdre ton temps...