XL 2013 Regroupement de données selon plusieurs critères..

job75

XLDnaute Barbatruc
Re,

Le bug vient certainement du fait que votre version Excel est une version anglaise, vous auriez pu nous le dire.

Il faut donc entrer les formules de la MFC dans une cellule et récupérer les FormulaLocal pour fonctionner sous toute version :
Code:
Sub Grouper()
Dim dest As Range, t, ub&, a(), i&, k%, n&, x$, j&
Application.ScreenUpdating = False
With ActiveSheet 'si la macro est dans un autre fichier
    Set dest = .[G1] '1ère cellule des résultats, à adapter
    t = .[A1].CurrentRegion.Resize(, 5) '5 colonnes
    ub = UBound(t)
    ReDim a(1 To ub * (UBound(t, 2) + 1), 1 To 2) '2 colonnes
    For i = 2 To ub
        n = n + 1 '1 ligne de séparation
        x = t(i, 2) & t(i, 3) & t(i, 4)
        For k = 1 To 5
            n = n + 1: a(n, 1) = t(1, k): a(n, 2) = t(i, k)
        Next k
        For j = i + 1 To ub
            If t(j, 2) & t(j, 3) & t(j, 4) <> x Then Exit For
            If t(j, 1) <> t(j - 1, 1) Then a(n - 4, 2) = a(n - 4, 2) & "." & t(j, 1)
            a(n, 2) = a(n, 2) + t(j, 5)
        Next j
        i = j - 1
    Next i
    With dest
        If n Then
            With dest(1, 2)
                '---copie de la 1ère condition de la MFC---
                .Parent.[A2].Copy
                .Resize(n).PasteSpecial xlPasteFormats 'collage spécial
                Application.CutCopyMode = 0
                '---2ème condition de la MFC---
                .Formula = "=AND(MOD(ROW()-ROW(" & .Address & "),6)=3," & .Address(0) & ">25)"
                .Resize(n).FormatConditions.Add(Type:=xlExpression, Formula1:=.FormulaLocal).Font.Color = vbRed 'police rouge
                '---3ème condition de la MFC---
                .Formula = "=AND(MOD(ROW()-ROW(" & .Address & "),6)=5," & .Address(0) & "<=5)"
                With .Resize(n).FormatConditions.Add(Type:=xlExpression, Formula1:=.FormulaLocal)
                    .Font.Color = vbRed: .Font.Bold = True 'police rouge gras
                End With
            End With
            .Resize(n, 2) = a 'restitution du tableau
        End If
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).Clear 'RAZ en dessous
        .Resize(, 2).EntireColumn.AutoFit 'ajustement largeur
    End With
    Application.GoTo .[A1], True 'cadrage
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
Comme vous pouvez le voir la cellule dest est maintenant G1 et j'ai introduit une ligne de séparation.

Edit : bah j'avais oublié d'ajouter 1 à UBound(t, 2) pour le dimensionnement du tableau a.

Fichier (4).

A+
 

Fichiers joints

Dernière édition:

anri0610

XLDnaute Junior
teste et approuve et enregistrer cela fonctionne parfaitement merci!
reste seulement les deux derniers soucis évoques précédemment !

oui tout a fait c'est ma faute , je ne savais seulement pas ce qu'il aurait été important de préciser !
j'ai modifier mon profil et je ferait attention a l'avenir merci pour la remarque .
 

Dranreb

XLDnaute Barbatruc
Bonjour.
1. Il ne peut pas y avoir me semble t-il de doublon du critère de la 1ere colonne: ils sont tous cumulés. Donc l'ex= 301.301.307.308 ne peut pas apparaître. Le 3ième non plus AW-1.AD-1.AW-2.AD-2 ce sera obligatoirement AD-1.AD-2.AW-1.AW-2. J'ai ajouter du code pour ne plus répéter les préfixes identiques spécifiés devant un "-"
2. Il suffisait de déplacer le LR = LR + 1 juste avant le Next Arg2
Le tout pour la partie qui est de moi donne ça :
VB:
   Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, TTit(), RngCbl As Range, _
      TJoin() As String, J As Long, RngPoliceRg As Range, PfxArg As String, P As Long
   TTit = ActiveSheet.[A1:E1].Value
   ReDim TR(1 To 100000, 1 To 3)
   Set RngCbl = ActiveSheet.[G2].Resize(UBound(TR, 1), 3)
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -4, -3, 1)
      For Each Arg4 In Arg2.Co
         For Each Arg3 In Arg4.Co
            ReDim TJoin(1 To Arg3.Count): J = 0
            For Each Arg1 In Arg3.Co: J = J + 1: TJoin(J) = Arg1.Id: Next Arg1
            PfxArg = "?"
            For J = 1 To UBound(TJoin)
               P = InStr(TJoin(J), "-")
               If Left$(TJoin(J), P) = PfxArg Then TJoin(J) = Mid$(TJoin(J), P + 1) Else PfxArg = Left$(TJoin(J), P)
               Next J
            LR = LR + 1: TR(LR, 1) = TTit(1, 1): TR(LR, 2) = "'" & Join(TJoin, ".")
            LR = LR + 1: TR(LR, 1) = TTit(1, 2): TR(LR, 2) = Arg2.Id: If Arg2.Id > 200 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5): If Arg4.Somme(5) <= 5 Then TR(LR, 3) = 1
            Next Arg3, Arg4
      LR = LR + 1: Next Arg2
   RngCbl.Value = TR
   On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants)
   If Err = 0 Then
      RngCbl.Offset(, -1).Font.Color = &HFF&
      RngCbl.ClearContents: End If
Remarque: il me semble absurde d'ajouter chaque fois une copie de la mise en forme conditionnelle sur la colonne H. Vous en voudrez combien comme ça, des centaines ?
 
Dernière édition:

anri0610

XLDnaute Junior
Tout est complètement parfait ! Je vous remercie infiniment !!!
je ne saurait comment vous remercier (a tous) a mon niveau je n'y serait jamais arriver seul !

ps= je n'ai pas compris votre remarque ..
 

Dranreb

XLDnaute Barbatruc
Alez voir du coté des mise en formes conditionnelles, vous verrez… A chaque exécution vous en ajoutez une qui existe déjà sur la colonne H. C'est du moins comme ça dans votre dernier PERSONAL.xlsm joint.
 

job75

XLDnaute Barbatruc
Re,

Pour la dernière demande :
cependant je souhaiterai que cet espace s' effectue uniquement si la valeur de la colonne B diffère .
voyez ce fichier (5) et la macro :
Code:
Sub Grouper()
Dim dest As Range, t, ub&, a(), i&, k%, n&, x$, j&
Application.ScreenUpdating = False
With ActiveSheet 'si la macro est dans un autre fichier
    Set dest = .[G1] '1ère cellule des résultats, à adapter
    t = .[A1].CurrentRegion.Resize(, 5) '5 colonnes
    ub = UBound(t)
    ReDim a(1 To ub * (UBound(t, 2) + 1), 1 To 2) '2 colonnes
    For i = 2 To ub
        If t(i, 2) <> t(i - 1, 2) Then n = n + 1 '1 ligne de séparation
        x = t(i, 2) & t(i, 3) & t(i, 4)
        For k = 1 To 5
            n = n + 1: a(n, 1) = t(1, k): a(n, 2) = t(i, k)
        Next k
        For j = i + 1 To ub
            If t(j, 2) & t(j, 3) & t(j, 4) <> x Then Exit For
            If t(j, 1) <> t(j - 1, 1) Then a(n - 4, 2) = a(n - 4, 2) & "." & t(j, 1)
            a(n, 2) = a(n, 2) + t(j, 5)
        Next j
        i = j - 1
    Next i
    With dest
        If n Then
            With dest(1, 2)
                '---copie de la 1ère condition de la MFC---
                .Parent.[A2].Copy
                .Resize(n).PasteSpecial xlPasteFormats 'collage spécial
                Application.CutCopyMode = 0
                '---2ème condition de la MFC---
                .Resize(n).FormatConditions.Add(Type:=xlExpression, _
                    Formula1:="=(" & dest.Address(0) & "=$C$1)*(" & .Address(0) & ">25)").Font.Color = vbRed 'police rouge
                '---3ème condition de la MFC---
                With .Resize(n).FormatConditions.Add(Type:=xlExpression, Formula1:="=(" & dest.Address(0) & "=$E$1)*(" & .Address(0) & "<=5)")
                    .Font.Color = vbRed: .Font.Bold = True 'police rouge gras
                End With
            End With
            .Resize(n, 2) = a 'restitution du tableau
        End If
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).Clear 'RAZ en dessous
        .Resize(, 2).EntireColumn.AutoFit 'ajustement largeur
    End With
    Application.GoTo .[A1], True 'cadrage
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
Les formules de la MFC font maintenant référence aux titres en colonne G et pas aux numéros de lignes, elles sont valables sur toute version.

A+
 

Fichiers joints

anri0610

XLDnaute Junior
Bonjour merci , cela fonctionne super !
par contre depuis ce matin j'ai un petit soucis j'ai opter pour un filtrage des données de colonnes en ordre non plus B>D>C mais maintenant B>C>D,
comme ci dessous:
VB:
        Columns("A:E").Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range( _
        "B1:B1000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    ActiveSheet.Sort.SortFields.Add Key:=Range( _
        "C1:C1000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    ActiveSheet.Sort.SortFields.Add Key:=Range( _
        "D1:D1000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("A1:E1000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
jusque la pas de soucis,
seulement au moment du regroupement via gigogne regrouper ou bien encore la macro grouper de Job75,
je n'obtient plus le même ordre dans les résultats et ça se mélange, je voudrais garder l'ordre de regroupement des données dans l'ordre des colonnes B>C>D,
pourriez vous me dire ce qu'il faudrait modifier ? (j'ai chercher a comprendre mais je n'ai pas trouver ni dans les macro ni dans Mgigogne..)
je vous joint les fichiers.

(veuillez m'excuser pour la réponse tardive , j'etait en repos et je n'ai pas réussi a installer office sur mon mac..avec la License du travail ><
pourriez vous me dire comment vous remercier pour tous vos efforts ! peut être un don ou je ne saurais )
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonjour
Pour Gigogne c'est l'ordre des numéros de colonnes spécifiés derrière (en négatif pour un classement en ordre décroissant).
Attention: l'ordre d'imbrication des boucles sur les SsGr doit être corrigé en conséquence.
Le classement des données n'est pas nécessaire, toutefois pour un très gros volume de données il peut accélérer le traitement.
 

anri0610

XLDnaute Junior
bonjour,
merci!
j'ai essayer et chercher plusieurs choses mais je n'ai trouver que l'ordre des données..
VB:
   For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -4, -3, 1)
pourriez vous m’éclairer pour modifier gigogne et SsGr?
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Il n'y a rien à modifier dans la programmation de service. Juste dans votre procédure applicative mettre à la place :
Code:
 For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -3, -4, 1)
Et corriger en conséquence l'ordre d'imbrication des boucles qui suivent :
For Each Arg3 In Arg2.Co … For Each Arg4 In Arg3.Co … For Each Arg1 In Arg4.Co … Next Arg1 … Next Arg4 … Next Arg3 … Next Arg2
 

anri0610

XLDnaute Junior
Bonjour merci !
voici l'erreur que j'obtient,

VB:
   For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -4, -3, 1)
      For Each Arg3 In Arg2.Co
         For Each Arg4 In Arg3.Co
            ReDim TJoin(1 To Arg3.Count): j = 0
            For Each Arg1 In Arg4.Co: j = j + 1[COLOR=#ff4d4d]: TJoin(j) = Arg1.Id[/COLOR]: Next Arg1
            PfxArg = "?"
            For j = 1 To UBound(TJoin)
               P = InStr(TJoin(j), "-")
               If Left$(TJoin(j), P) = PfxArg Then TJoin(j) = Mid$(TJoin(j), P + 1) Else PfxArg = Left$(TJoin(j), P)
               Next j
            LR = LR + 1: TR(LR, 1) = TTit(1, 1): TR(LR, 2) = "'" & Join(TJoin, ".")
            LR = LR + 1: TR(LR, 1) = TTit(1, 2): TR(LR, 2) = Arg2.Id: If Arg2.Id > 200 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5): If Arg4.Somme(5) <= 5 Then TR(LR, 3) = 1
            Next Arg4, Arg3
      LR = LR + 5: Next Arg2
   RngCbl.Value = TR
   On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants)
   If Err = 0 Then
      RngCbl.Offset(, -1).Font.Color = &HFF&
      RngCbl.ClearContents: End If
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonjour.
Vous n'avez pas dit quelle erreur c'est, justement, mais ça doit être un indice en dehors des limites parce que vous avez dimensionné TJoin selon le nombre d'Arg4 dans Arg3 au lieu du nombre d'Arg1 dans Arg4. Ça doit être :
VB:
         ReDim TJoin(1 To Arg4.Count): J = 0
Mais il y a plus grave : Vous avez laissé les numéros de colonnes -2, -4, -3, 1 à l'appel de Gigogne au lieu de mettre -2, -3, -4, 1
Il se peut que ça ne plante pas, mais ça va intervertir les valeurs de la colonne 4 dans les Arg3.Id et celles de la 3 dans les Arg4.Id sans donner à cette colonne 3 la priorité sur la 4 du classement et du regroupement.
 
Dernière édition:

anri0610

XLDnaute Junior
Bonjour,
Dranreb je souhaiterai effectuer un petit ajout au module regrouper,
j'ai effectuer quelques améliorations depuis et je souhaiterai a présent pour ligne de données ajouter une information présente dans la colonne qui suit (colonneF),
et la faire apparaître dans la colonne I a la droite de la somme .
(les données présentes dans cette nouvelle colonne correspondent a la couleur du produit)
pourriez vous m aider s'il vous plait!?

ce n 'est d'aucune aide je pense mais j'ai tenter désespérément de modifier le code moi-même en essayant d'ajouter un Arg5 :

VB:
   Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, Arg5 As SsGr, TTit(), RngCbl As Range, _
      TJoin() As String, j As Long, RngPoliceRg As Range, PfxArg As String, P As Long
   TTit = ActiveSheet.[A1:F1].Value
   ReDim TR(1 To 100000, 1 To 3)
   Set RngCbl = ActiveSheet.[G2].Resize(UBound(TR, 1), 3)
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(ActiveSheet.[A2:F2], -2, -3, -4, 1, -5)
      For Each Arg3 In Arg2.Co
         For Each Arg4 In Arg3.Co
                  For Each Arg5 In Arg4.Co

            ReDim TJoin(1 To Arg4.Count): j = 0
            For Each Arg1 In Arg4.Co: j = j + 1: TJoin(j) = Arg1.Id: Next Arg1
            PfxArg = "?"
            For j = 1 To UBound(TJoin)
               P = InStr(TJoin(j), "-")
               If Left$(TJoin(j), P) = PfxArg Then TJoin(j) = Mid$(TJoin(j), P + 1) Else PfxArg = Left$(TJoin(j), P)
               Next j
            LR = LR + 1: TR(LR, 1) = TTit(1, 1): TR(LR, 2) = "'" & Join(TJoin, ".")
            LR = LR + 1: TR(LR, 1) = TTit(1, 2): TR(LR, 2) = Arg2.Id: If Arg2.Id > 200 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5): If Arg4.Somme(5) <= 5 Then TR(LR, 3) = 1
            Next Arg5, Arg4, Arg3
      LR = LR + 5: Next Arg2
   RngCbl.Value = TR
   On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants)
   If Err = 0 Then
      RngCbl.Offset(, -1).Font.Color = &HFF&
      RngCbl.ClearContents: End If
 

Fichiers joints

anri0610

XLDnaute Junior
Je souhaiterai au moins vous poser la question pour savoir si seulement c est possible..
etant donner que ce serait l'ideal pour que votre outil soit applicable complètement dans mon cas ,
je vais essayer d’être clair,

Dans L'ordre des données de la colonne F définir pour chaque valeur (nom de couleur) identique une référence interne qui donnerai couleur1, couleur2 etc.
pour ensuite modifier le placement de la somme pour chaque ligne, ce qui donnerai pour couleur1, toujours le placement en -4, si couleur2 existe le placement en -5, si couleur 3 existe en -6 etc
ce qui laisserait des espaces entre les valeur d'une même ligne , ce qui est exactement le but rechercher !
je souhaiterai savoir si ce serait possible d'en demander autant.
merci bien !
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonjour.
Je ne comprends pas bien ce que vous voulez.
Déjà la colonne F c'est la 6, pas la 5. Et vous voudriez aussi un classement en ordre décroissant et un regroupement dessus ? Et dans ce cas ne devrait-il pas venir avant le dernier regroupement sur la colonne 1 ? C'est d'ailleurs ce que semble indiquer l'imbrication de vos boucles.
En général je n'appelle pas mes SsGr Arg1, Arg2 etc. Je leur donne des noms en rapport avec les titres des colonnes. Mais là c'est du japonais, alors… Pour rester dans la logique appelez Arg6 un SsGr pour la colonne 6.
Qu'est ce que vous appelez le placement ?
 

anri0610

XLDnaute Junior
Bonjour Dranreb,
je souhaiterai le résultat que j'ai joint en print screen,

mon premier message=

je souhaiterai seulement indiquer la reference couleur a droite de la somme via Mregrouper
(pour chaque ligne regroupée, de manière a ne pas faire la somme et mélanger des couleurs différentes)
pour ensuite faire le tri manuellement.

mon deuxième message=

je souhaiterai avoir un regroupement avec comme dernière règle de regroupement les données de cette colonne F,
en identifiant le nombre de couleur présentes dans le fichier traiter , de par le nombre de "nom de couleur" différents peut etre,
pour ensuite placer selon la couleur, la somme de regroupement actuelle.
Cette position serait dans le cas de la couleur 1, a la position actuelle en 5 en dessous des données de la colonne D.
Dans le cas d'une couleur 2, -1 en dessous , donc en 6 en laissant 1 espace entre les données de la colonne D et la somme.
Dans le cas d'une couleur 3, -2 en dessous, donc en 7 en laissant 2 espace entre les données de la colonne D et la somme.
Dans le cas d'une couleur 4, -3 en dessous, donc en 7 en laissant 2 espace entre les données de la colonne D et la somme.
etc
puis toujours si seulement c'est possible,
si pour un regroupement nous avons toutes les mêmes données, (donc jusqu’à maintenant un regroupement complet)
mais des valeurs différentes dans la colonne F alors regrouper mais placer la somme selon couleur 1>en 5 ; couleur2>en 6 ; couleur3>en 7 ...etc.
puis passer a la ligne suivante.

Le but principal étant de différencier les différents produits mélanger via le regroupement actuel ,
dans la réalité pour les mêmes données c'est a dire largeur longueur hauteur, nous auront un produit différent au niveau de la forme,
a ce niveau la il est nécessaire de les dissocier manuellement car les données n'informent pas un croquis et donc la forme .

Cependant la couleur du produit est indiquée par un nom/numéro,
au moment du regroupement de produits (via CAD) pour plusieurs couleurs de produits différent je définit par exemple couleur 1= 501
couleur2= 502 et dans le croquis la somme indiquée dans un tableau se trouve en dessous des chiffres 1,2,
j'aurai besoin de la forme de regroupement expliquée pour pouvoir comme dans le cadre d'une seule couleur présente pouvoir copier les données regroupées sans les modifier manuellement.

en espérant avoir été un petit peut plus clair..

je vous joint ce que représente le fichier final pour 4 couleur, cela vous éclairera peut être..
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonjour.
VB:
   Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, Arg6 As SsGr, TTit(), RngCbl As Range, _
      TJoin() As String, J As Long, RngPoliceRg As Range, PfxArg As String, P As Long
   TTit = ActiveSheet.[A1:E1].Value
   ReDim TR(1 To 100000, 1 To 3)
   Set RngCbl = ActiveSheet.[G2].Resize(UBound(TR, 1), 3)
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -3, -4, 1, 6)
      For Each Arg3 In Arg2.Co
         For Each Arg4 In Arg3.Co
            ReDim TJoin(1 To Arg3.Count): J = 0
            PfxArg = "?"
            For Each Arg1 In Arg4.Co: P = InStr(Arg1.Id, "-"): J = J + 1
               If Left$(Arg1.Id, P) <> PfxArg Then
                  TJoin(J) = Arg1.Id: PfxArg = Left$(Arg1.Id, P)
               Else: TJoin(J) = Mid$(Arg1.Id, P + 1): End If
               For Each Arg6 In Arg1.Co
'                Le problème c'est que je ne comprends pas du tout ce que vous voudriez faire à cet endroit.
'                Au fait la concaténation des Arg1 est-elle bien toujours d'actualité ?
'                Si le regroupement sur Agr6 est indépendant de celui sur Arg1 ça va devenir très compliqué, presque impossible !
                  Next Arg6, Arg1
            LR = LR + 1: TR(LR, 1) = TTit(1, 1): TR(LR, 2) = "'" & Join(TJoin, ".")
            LR = LR + 1: TR(LR, 1) = TTit(1, 2): TR(LR, 2) = Arg2.Id: If Arg2.Id > 200 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5): If Arg4.Somme(5) <= 5 Then TR(LR, 3) = 1
            Next Arg4, Arg3
      LR = LR + 5: Next Arg2
   RngCbl.Value = TR
   On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants)
   If Err = 0 Then
      RngCbl.Offset(, -1).Font.Color = &HFF&
      RngCbl.ClearContents: End If
En fait il semblerait que le Arg1 ne se justifie plus dans vos dernières données: il n'y en a chaque fois qu'un seul dans chaque Arg4. Mais on peut le garder, juste pour avoir son Id, mais on aurait intérêt, si jamais il venait à y en avoir à nouveau plusieurs, à refaire un paquet entier des 5 lignes pour chaque.
On pourrait peut être faire la boucle For Each Arg6 In Arg1.Co après les LR = LR + 1: TR(LR, 1) = etc.
et donc en refaire un pour chaque couleur.
Essayez ça: ça ne paraît pas inintéressant :
VB:
   Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, Arg6 As SsGr, TTit(), RngCbl As Range, _
      TJoin() As String, J As Long, RngPoliceRg As Range, PfxArg As String, P As Long
   TTit = ActiveSheet.[A1:F1].Value
   ReDim TR(1 To 100000, 1 To 3)
   Set RngCbl = ActiveSheet.[G2].Resize(UBound(TR, 1), 3)
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(ActiveSheet.[A2:F2], -2, -3, -4, 1, 6)
      For Each Arg3 In Arg2.Co
         For Each Arg4 In Arg3.Co
            For Each Arg1 In Arg4.Co
            LR = LR + 1: TR(LR, 1) = TTit(1, 1): TR(LR, 2) = Arg1.Id
            LR = LR + 1: TR(LR, 1) = TTit(1, 2): TR(LR, 2) = Arg2.Id: If Arg2.Id > 200 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then TR(LR, 3) = 1
            LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg1.Somme(5): If TR(LR, 2) <= 5 Then TR(LR, 3) = 1
            For Each Arg6 In Arg1.Co
               LR = LR + 1: TR(LR, 1) = TTit(1, 6): TR(LR, 2) = Arg6.Id
               LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg6.Somme(5): If TR(LR, 2) <= 5 Then TR(LR, 3) = 1
               Next Arg6, Arg1, Arg4, Arg3
      LR = LR + 5: Next Arg2
   RngCbl.Value = TR
   On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants)
   If Err = 0 Then
      RngCbl.Offset(, -1).Font.Color = &HFF&
      RngCbl.ClearContents: End If

Je vous suggère d'utiliser ce classeur pour faire des essais de la fonction Gigogne sur vos données
 

Fichiers joints

Dernière édition:

anri0610

XLDnaute Junior
Bonjour j'aurais vraiment essayer tout ce que j'ai pu mais je n’arrête pas de m'embrouiller..

je pense qu'il n'est pas nécessaire que je note ce que j'ai essayer , j'ai essayer de modifier tous les ordres des arg sans atteindre le résultat souhaiter , je perdais soit le calcul de la somme soit j'avais en arg6.id une valeur différente...

aidez moi s'il vous plait,

je souhaiterai garder le résultat actuel , seulement ajouter la valeur de la colonne F,
(cet arg6), dans le même cadre de fonctionnement que les autres arg,
de manière a ce que comme jusqu’à maintenant la somme s'effectue si et quand toutes les valeur sont identiques.
de manière a séparer et ne pas mélanger les données de cette colonne F,
et seulement afficher a droite de la somme(5) la valeur correspondante a arg6.id pour information.

je ne souhaite pas modifier l’écriture actuelle de la colonne I.
aidez moi s'il vous plait je suis complètement perdu..
 

Fichiers joints

Discussions similaires


Haut Bas