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

anri0610

XLDnaute Junior
Bonjour a tous,

Mon soucis:
effectuer la somme des valeurs de la colonne E si/quand les valeurs des colonnes A B C D sont toutes identiques,
j'aurais pourtant essayer d être clair... ><

je vous joint le fichier concerne, sachant que les valeurs diffèrent toutes a chaque travail donc impossible de définir une règle pour une quelconque valeur.

ex/
maintenant:

AW-1 110 25 2100 10
AW-1 110 25 2100 10
AW-1 110 25 2100 10
AW-1 110 25 2100 10
AW-1 110 25 2100 10
AW-3 110 25 800 10

résultat souhaite:

AW-1 110 25 2100 50
AW-3 110 25 800 10

je souhaiterai effectuer ce résultat avec une macro,
et ne pas transformer la mise en forme des données pour un tableau dynamique.
est-ce seulement possible ?
 

Pièces jointes

  • TEST.xlsx
    10 KB · Affichages: 50

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+
 

Pièces jointes

  • resultat job75(4).xlsm
    29.3 KB · Affichages: 26
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:

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+
 

Pièces jointes

  • resultat job75(5).xlsm
    29.4 KB · Affichages: 34

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 )
 

Pièces jointes

  • probleme regrouper.xlsm
    1.1 MB · Affichages: 24
  • PERSONAL.xlsm
    72.7 KB · Affichages: 32

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.
 

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
 

Pièces jointes

  • erreur arg1.png
    erreur arg1.png
    142.4 KB · Affichages: 28

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
 

Pièces jointes

  • TEST.xlsm
    1.1 MB · Affichages: 45
  • regrouper colonneF.png
    regrouper colonneF.png
    107.1 KB · Affichages: 14
  • PERSONAL.xlsm
    69.2 KB · Affichages: 21

Discussions similaires

Réponses
36
Affichages
1 K

Statistiques des forums

Discussions
311 720
Messages
2 081 897
Membres
101 833
dernier inscrit
sandra25