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

Dranreb

XLDnaute Barbatruc
J'ai dit ActiveSheet, en un seul mot, pas active sheet
 

anri0610

XLDnaute Junior
je viens de me rendre compte excuser moi ,
avec ma macro CAD dans mon fichier test,
en fonction des colonnes j'avais selon certains critères(>25, =2500, >200,etc) mes valeurs en rouge,
avec ma macro apsaly que j'avais régler tout bêtement pour transposer cela me copiait les données telles quelles,
atout qui malheureusement a disparut avec gigogne y aurait il une possibilité ?
 

Dranreb

XLDnaute Barbatruc
Il devrait être possible de mettre des mises en forme conditionnelles, mais elle seraient peut être un peu compliquées
Il serait possible de mettre une couleur de fond à chaque paquet selon la valeur
 

anri0610

XLDnaute Junior
je ne m’était pas tromper pour l’écriture du code (je ferais attention a ne plus faire de faute pour du language de code)
mais pardon,
j'avais du manquer quelque chose j'ai réussi !

Ne me reste plus que le regroupement des noms de la colonne A et mes valeurs de filtre en rouges s'il vous plait, votre aide est précieuse !
 

Dranreb

XLDnaute Barbatruc
Il faut me donner plus de précisions si vous voulez que la macro Regrouper colore les paquets selon les valeurs de la somme.
 

anri0610

XLDnaute Junior
Voici pour l'instant les seules conditions que j'utilise,

VB:
    Range("C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=25"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
        Formula1:="=200"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("D2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=2150"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
 

anri0610

XLDnaute Junior
j'ai essayer gigogne avec un nouveau fichier un petit peu plus embêtant
et j'obtient un étrange résultat.. uniquement les sommes sont répétées?
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Pour la questions d'avant, essayez comme ça :
VB:
Sub Regrouper()
   Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, _
      RngCbl As Range
   ReDim TR(1 To ActiveSheet.UsedRange.Rows.Count * 5, 1 To 1)
   Set RngCbl = ActiveSheet.[G2].Resize(UBound(TR, 1))
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -3, -4, 1)
      For Each Arg3 In Arg2.Co
         For Each Arg4 In Arg3.Co
            For Each Arg1 In Arg4.Co
               LR = LR + 1: TR(LR, 1) = Arg1.Id
               LR = LR + 1: TR(LR, 1) = Arg2.Id: If Arg2.Id = 25 Then RngCbl(LR, 1).Font.Color = -16776961
               LR = LR + 1: TR(LR, 1) = Arg3.Id: If Arg3.Id = 200 Then RngCbl(LR, 1).Font.Color = -16776961
               LR = LR + 1: TR(LR, 1) = Arg4.Id: If Arg4.Id = 2150 Then RngCbl(LR, 1).Font.Color = -16776961
               LR = LR + 1: TR(LR, 1) = Arg4.Somme(5)
               Next Arg1, Arg4, Arg3, Arg2
      RngCbl.Value = TR
   End Sub
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
C'est sûr que c'est beaucoup moins lisible quand il y a un nombre au lieu d'un texte en colonne A !
Pour repérer visuellement les paquets, je veux dire. Depus le début cette disposition me parait anormale d'ailleurs, mais c'est vous qui voyez.
 

anri0610

XLDnaute Junior
je vous envoi un exemple du résultat idéal souhaite ,
j'ai eu un soucis également avec l'ordre des données pour les valeurs présentes aux lignes 57,58.
(qui se retrouvent mélangées au lieu d’être a la fin)

(je pense cela un détail mais dans le doute je préfère le préciser,
je pensais essayer après tout ça de faire en sorte que,
les valeur de la colonne C changent sous cette condition, si égal a 25 alors modifier en 24.)
 

Fichiers joints

anri0610

XLDnaute Junior
Pour la questions d'avant, essayez comme ça :
VB:
Sub Regrouper()
   Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, _
      RngCbl As Range
   ReDim TR(1 To ActiveSheet.UsedRange.Rows.Count * 5, 1 To 1)
   Set RngCbl = ActiveSheet.[G2].Resize(UBound(TR, 1))
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -3, -4, 1)
      For Each Arg3 In Arg2.Co
         For Each Arg4 In Arg3.Co
            For Each Arg1 In Arg4.Co
               LR = LR + 1: TR(LR, 1) = Arg1.Id
               LR = LR + 1: TR(LR, 1) = Arg2.Id: If Arg2.Id = 25 Then RngCbl(LR, 1).Font.Color = -16776961
               LR = LR + 1: TR(LR, 1) = Arg3.Id: If Arg3.Id = 200 Then RngCbl(LR, 1).Font.Color = -16776961
               LR = LR + 1: TR(LR, 1) = Arg4.Id: If Arg4.Id = 2150 Then RngCbl(LR, 1).Font.Color = -16776961
               LR = LR + 1: TR(LR, 1) = Arg4.Somme(5)
               Next Arg1, Arg4, Arg3, Arg2
      RngCbl.Value = TR
   End Sub
est ce a rajouter ou bien a remplacer ?
(en remplaçant je n'ai plus de réaction.)
 

anri0610

XLDnaute Junior
C'est sûr que c'est beaucoup moins lisible quand il y a un nombre au lieu d'un texte en colonne A !
Pour repérer visuellement les paquets, je veux dire. Depus le début cette disposition me parait anormale d'ailleurs, mais c'est vous qui voyez.
Cette disposition est toute a fait anormale, je suis seulement dans l'obligation de mettre les valeurs a la verticales sinon les données sont
malheureusement inutilisables, pour la suite avec un autre logiciel.
je souhaitait cependant si c’était possible a faire en sorte qu'après chaque regroupement de données on laisse un espace (une ligne) puis passer
a la suite , ce qui serait plus lisible déjà , je ne sais trop juger la
difficulté de ces modifications donc je n'ai demander de l'aide que sur l'essentiel.

ps: je dois rentrer , je vous lit et réponds demain, encore merci pour votre aide ! :)
 

Dranreb

XLDnaute Barbatruc
Et pour l'autre jeu de données, c'est une autre procédure alors ? La colonne E des données doit elle être cumulée sur toute la combinaison de valeurs des colonnes B:D toutes valeurs confondues de la colonne A ?
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Essayez comme ça :
VB:
Sub Regrouper2()
   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
   TTit = ActiveSheet.[A1:E1].Value
   ReDim TR(1 To 100000, 1 To 2)
   Set RngCbl = ActiveSheet.[K2].Resize(UBound(TR, 1), 2)
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -3, -4, 1)
      For Each Arg3 In Arg2.Co
         For Each Arg4 In Arg3.Co
            ReDim TJoin(1 To Arg4.Count): J = 0
            For Each Arg1 In Arg4.Co: J = J + 1: TJoin(J) = Arg1.Id: Next 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 RngCbl(LR, 2).Font.Color = -16776961
            LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then RngCbl(LR, 2).Font.Color = -16776961
            LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then RngCbl(LR, 2).Font.Color = -16776961
            LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5)
            Next Arg4, Arg3, Arg2
      RngCbl.Value = TR
   End Sub
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour anri0610, Bernard, le forum,

Pour obtenir le "résultat idéal souhaité" :
Code:
Sub Grouper()
Dim dest As Range, P 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 = .[G2] '1ère cellule des résultats, à adapter
    Set P = .[A1].CurrentRegion.Resize(, 5) '5 colonnes
    t = P
    ub = UBound(t)
    ReDim a(1 To ub * UBound(t, 2), 1 To 1)
    For i = 2 To ub
        x = t(i, 2) & t(i, 3) & t(i, 4)
        For k = 1 To 5
            n = n + 1: a(n, 1) = t(i, k)
        Next
        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, 1) = a(n - 4, 1) & "." & t(j, 1)
            a(n, 1) = a(n, 1) + t(j, 5)
        Next
        P.Rows(i).Copy
        dest(n - 4).PasteSpecial xlPasteFormats, Transpose:=True 'collage spécial
        i = j - 1
    Next i
    Application.CutCopyMode = 0
    With dest
        If n Then .Resize(n) = a
        .Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
        .EntireColumn.AutoFit 'ajustement largeur
    End With
    Application.GoTo .[A1], True 'cadrage
    With .UsedRange: End With 'actualise la barre de defilement verticale
End With
End Sub
Les formats sont copiés avec transposition, cela prendra évidemment du temps sur un gros fichier.

Fichier joint.

A+
 

Fichiers joints

Dernière édition:

Dranreb

XLDnaute Barbatruc
Avec un espace entre chaque paquet :
VB:
Sub Regrouper()
   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
   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
            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)
            LR = LR + 1
            Next Arg3, Arg4, Arg2
   RngCbl.Value = TR
   On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants)
   If Err Then Exit Sub
   RngCbl.Offset(, -1).Font.Color = &HFF&
   RngCbl.EntireColumn.Delete
   End Sub
Ah oui attention, l'ordre de classement a changé. Voir si cette procédure est quand même adaptée aux deux configurations.
 

job75

XLDnaute Barbatruc
Re,

J'ai testé ma solution du post #55 après avoir copié le tableau A2:E58 jusqu'à la ligne 5701.

La macro s'exécute chez moi en 2 minutes environ, c'est beaucoup trop long.

Comme l'a suggéré Bernard il faut donc recréer la MFC (2 conditions) en colonne G :
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 = .[G2] '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 To 1)
    For i = 2 To ub
        x = t(i, 2) & t(i, 3) & t(i, 4)
        For k = 1 To 5
            n = n + 1: a(n, 1) = t(i, k)
        Next
        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, 1) = a(n - 4, 1) & "." & t(j, 1)
            a(n, 1) = a(n, 1) + t(j, 5)
        Next
        i = j - 1
    Next i
    With dest
        If n Then
            .Resize(n) = a
            '---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:= _
                "=ET(MOD(LIGNE()-LIGNE(" & dest.Address & ");5)=2;" & dest.Address(0, 0) & ">25)") _
                    .Font.Color = vbRed 'police rouge
        End If
        .Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
        .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
Fichier (2), maintenant sur 5700 lignes la macro s'exécute en 0,12 seconde.

A+
 

Fichiers joints

anri0610

XLDnaute Junior
Tout d'abords un grand grand merci !!! le résultat est bluffant, je n'imaginait pas mieux !

il me reste 2,3 petites requêtes et je crois bien que ce sera parfait !
désoler de dépendre complètement de vous..

1-

Je souhaiterai toujours si possible,
que dans le regroupement (colonne H) des données de la colonne A,
(uniquement bien sur pour les conditions de regroupement actuelles)
que les doubles soient supprimer que ce soit des lettres ou des chiffres,

ex= AW-1.AW-3 -> AW-1.3

ex= 301.301.307.308 -> 301.307.308

par contre dans ce cas la:

ex= AW-1.AD-1.AW-2.AD-2 -> AW-1.2.AD-1.2 (si cela semble trop compliquer laisser comme tel AW-1.AD-1.AW-2.AD-2)

La réflexion est telle que si les lettres sont identique alors supprimer les valeur en double,
cependant si les lettres diffèrent (dans ce cas la AD-) regrouper les cas identiques ,
ou bien seulement ne pas confondre (en tant que doublon et supprimer juste les chiffres) ce qui donnerait AW-1.AD.AW-2.AD .



2-

j'ai compris que l'espace correspondait a :
VB:
LR = LR + 1
cependant je souhaiterai que cet espace s' effectue uniquement si la valeur de la colonne B diffère .
j'ai bien sur chercher a le faire par moi même mais je ne trouve toujours pas de solution .
j'ai alors essayer comme ça:
VB:
 For Each Arg1 In Arg3.Co: J = J + 1: TJoin(J) = Arg1.Id: Next 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 Arg2.Id <> Arg2.Id Then LR = LR + 1
            Next Arg3, Arg4, Arg2
ou:
VB:
 If Range("B" & Ligne) <> Range("B" & Ligne - 1) Then LR = LR + 1
Et bien d'autres mais évidemment cela ne marche pas .


ps=(Serait ce possible d'ajouter une condition pour que la somme des valeur de la colonne E ,
qui est transposée en colonne H soit affichée en rouge lorsque Égal ou Inférieur a 5 ?)
Je vient de réussir pour ca! :)
comme ca:
VB:
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
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Bonjour anri0610, le forum,

Vous ignorez les solutions que je propose mais ça m'est égal car il n'y a pas que vous que ça peut intéresser.

Et je découvre au compte-goutte vos desiderata.

Ici avec 2 colonnes de résultats et une 3ème condition pour la MFC en colonne H :
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 = .[G2] '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 To 2) '2 colonnes
    For i = 2 To ub
        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
            .Resize(n, 2) = a
            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:= _
                    "=ET(MOD(LIGNE()-LIGNE(" & .Address & ");5)=2;" & .Address(0) & ">25)") _
                        .Font.Color = vbRed 'police rouge
                '---3ème condition de la MFC---
                With .Resize(n).FormatConditions.Add(Type:=xlExpression, Formula1:= _
                    "=ET(MOD(LIGNE()-LIGNE(" & .Address & ");5)=4;" & .Address(0) & "<=5)")
                    .Font.Color = vbRed: .Font.Bold = True 'police rouge gras
                End With
            End With
        End If
        .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).Delete xlUp '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
Fichier (3).

Bonne journée.
 

Fichiers joints

anri0610

XLDnaute Junior
Bonjour Job75,

je vous assure que je n'ai ignorer aucun des posts qui m'ont été adresses,
pardon pour ma réponse tardive et vous avoir donner ce sentiment , et merci encore pour toutes vos propositions !
( il m'est inconcevable d'ignorer une aide alors que je suis incapable de me débrouiller seul ! )
et je suis d'accord avec vous cela peut servir a d'autres personnes mais aussi m'en apprendre plus sur les possibilités et la réflexion du codage !

effectivement j'utilise actuellement les propositions de Dranreb qui m'ont apporter de suite le résultat désirer ,
mais bien sur je regarde, je test et donne un feedback a toutes vos propositions ,
je vous joint maintenant pour vos 2 derniers messages l'erreur et le résultat obtenu en screen!
 

Fichiers joints

Discussions similaires


Haut Bas