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

anri0610

XLDnaute Junior
Bonjour Dranreb,

J'essaye comme je peux pour vous montrer que ce n'est pas du tout de la mauvaise foi,
je comprends ce que vous dites, mais c'est l'appliquer qui me bloque,
quoi modifier ou et comment,
je ne vais pas non plus vous envoyer mes essais aberrants de modifications par ci par la,
merci beaucoup c'est tres gentil de votre part d'essayer de m'expliquer mais je nage un peu dans un océan. Peut etre qu'il faudrait que je fasse chose par chose pour y arriver,
car si je modifier une chose que j'ai a peut prêt deviner, pour la suite quoi faire reste un
gros probleme..
mais pendant pas mal de temps sans vous contacter j'ai essayer plein de manières différentes dans ce genre la , en analysant le résultat pour trouver le comment du pourquoi, pour comprendre chaque chose et modifiant petit a petit..
malgré ça a chaque tentative aucune finalité toujours des erreurs que je ne résolvait pas.
voici ou j'en suis dans ce cas la sans modifier n'importe quoi,

VB:
   Dim TTit(), TInt(), TRes(), RngCbl As Range, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, Arg6 As SsGr, Arg7 As SsGr, _
      TS1() As String, TJoin() As String, J As Long, TS2() As String, P As Long, Nom As String, L As Long, Dico As Dictionary, TCoul(), C As Long, Detail
   TTit = ActiveSheet.[A1:G1].Value
'   Set Dico = DicInvent(ActiveSheet.[A2:F2], 6, 4)
   Set Dico = DicInvent(ActiveSheet.[A2:F2], 7, 1)
'   ReDim TRes(1 To 10000, 1 To 4 + Dico.Count)
   ReDim TRes(1 To 10000, 1 To 3)
   Set RngCbl = ActiveSheet.[H1].Resize(UBound(TRes, 1), UBound(TRes, 2))
'   VerserEntetes TRes, Dico
   TCoul = Dico.Keys: L = 1
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(Null, -2, -3, -4, 1)
      For Each Arg3 In Arg2.Co
          For Each Arg4 In Arg3.Co
            ReDim TJoin(1 To Arg4.Count): J = 0: ReDim TS1(-1 To -1)
            For Each Arg1 In Arg4.Co
               TS2 = Split(Arg1.Id, "-")
               For P = 0 To UBound(TS2) - 1: TS2(P) = TS2(P) & "-": Next P
               For P = 0 To UBound(TS1): If P >= UBound(TS2) Then Exit For
                  If TS2(P) <> TS1(P) Then Exit For
                  Next P
               Nom = "": While P <= UBound(TS2): Nom = Nom & TS2(P): P = P + 1: Wend
               J = J + 1: TJoin(J) = Nom: TS1 = TS2: Next Arg1
             L = L + 1: TRes(L, 1) = TTit(1, 1): TRes(L, 2) = Join(TJoin, ".")
            L = L + 1: TRes(L, 1) = TTit(1, 2): TRes(L, 2) = Arg2.Id: If Arg2.Id > 200 Then TRes(L, 3) = 1
            L = L + 1: TRes(L, 1) = TTit(1, 3): TRes(L, 2) = Arg3.Id: If Arg3.Id > 25 Then TRes(L, 3) = 1
            L = L + 1: TRes(L, 1) = TTit(1, 4): TRes(L, 2) = Arg4.Id: If Arg4.Id = 2150 Then TRes(L, 3) = 1
'            TRes(L, 3) = TTit(1, 5)
            TRes(L + 1, 1) = TTit(1, 5)
            For Each Arg1 In Arg4.Co
               For Each Detail In Arg1.Co
'                  C = Dico(Detail(6)): TRes(L, C) = TRes(L, C) + Detail(5)
                  C = L + Dico(Detail(6)): TRes(C, 2) = TRes(C, 2) + Detail(5)
'                 Next Detail, Arg1, Arg4, Arg3
                  Next Detail, Arg1
            For C = LBound(TCoul) To UBound(TCoul)
               L = L + 1: TRes(L, 3) = TCoul(C)
               Next C, Arg4, Arg3
           
           
            For Each Arg7 In Arg4.Co
               For Each Detail In Arg1.Co
'                  C = Dico(Detail(6)): TRes(L, C) = TRes(L, C) + Detail(5)
                  C = L + Dico(Detail(7)): TRes(C, 2) = TRes(C, 2)
'                 Next Detail, Arg1, Arg4, Arg3
                  Next Detail, Arg1
            For C = LBound(TCoul) To UBound(TCoul)
               L = L + 1: TRes(L, 3) = TCoul(C)
               Next C, Arg4, Arg3
           
           
      L = L + 5: Next Arg2
   RngCbl.Value = TRes
   On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants, 1)
   If Err = 0 Then
      RngCbl.Offset(, -1).Font.Color = &HFF&
      RngCbl.ClearContents: End If
je ne saurais quoi vous dire d'autre,

le but restant simple ce n'est pas une question d'ordre de regroupement ni rien du tout,
seulement de ne pas mélanger les regroupement effectues ,
ce qui dicte les différence a ne pas mélanger sont les données de la colonne G,
j'ai donc fais comme je pouvais pour arriver a ce résultat,
outre votre proposition d’amélioration qui me semblerait logique si bien sur j'y arrivait,

je souhaitais simplement afficher ces valeurs dans le regroupement,
peut importe la ligne tant que ça reste dans la colonne J,
tout simplement car en évoluant vers le bas de la Feuille, et bien je dois remonter pour
aller lire les donnes de la colonne G a chaque fois .

Afficher a coter de chaque regroupement les valeurs de cette colonne G,
qui en quelques sorte trie en dernier ces regroupement me permettrais de faire
la différence.

Si ça se trouve, vous avez une conception tellement imprécise des chose qu'il suffirait pour obtenir ce que vous vouliez d'ajouter dans la boucle For Each Detail une instruction TRes(C, 4) = Detail(7).
Egalement essayer de plusieurs manières différentes..

Code:
            For Each Arg1 In Arg4.Co
               For Each Detail In Arg1.Co
'                  C = Dico(Detail(6)): TRes(L, C) = TRes(L, C) + Detail(5)
                  C = L + Dico(Detail(6)): TRes(C, 2) = TRes(C, 2) + Detail(5)
                  C = L + Dico(Detail(7)) = TRes(C, 4)
'                 Next Detail, Arg1, Arg4, Arg3
                  Next Detail, Arg1
            For C = LBound(TCoul) To UBound(TCoul)
               L = L + 1: TRes(L, 3) = TCoul(C)
               Next C, Arg4, Arg3
Vraiment désoler pour tout ça je manque cruellement de connaissances..
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonjour.
Vous ne pouvez toujours pas reprendre de Detail(7) puisque les donnée spécifiées à DicInvent et reprises ensuite par Gigogne (du fait qu'on lui spécifie Null comme données à prendre pour qu'il n'ait pas à refaire le travail d'acquisition en tableau déjà effectué par DicInvent) ne comportent toujours que 6 colonnes (1ère ligne spécifiée : ActiveSheet.[A2:F2] au lieu de ActiveSheet.[A2:G2]).
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Voici un code qui produit un résultat :
VB:
Sub RegrouperSol2()
   Dim TTit(), Dico6 As Dictionary, TRes(), RngCbl As Range, TCoul(), L As Long, _
      Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, Arg7 As SsGr, Arg1 As SsGr, Detail, _
      J As Long, TS1() As String, TS2() As String, P As Long, Nom As String, C As Long
   TTit = ActiveSheet.[A1:G1].Value
   Set Dico6 = DicInvent(ActiveSheet.[A2:G2], 6, 1)
   ReDim TRes(1 To 100000, 1 To 3)
   Set RngCbl = ActiveSheet.[H1].Resize(UBound(TRes, 1), UBound(TRes, 2))
   TCoul = Dico6.Keys: L = 1
   RngCbl.Font.Color = 0
   For Each Arg2 In Gigogne(Null, -2, -3, -4, 7, 1)
      For Each Arg3 In Arg2.Co
         For Each Arg4 In Arg3.Co
            For Each Arg7 In Arg4.Co
               ReDim TJoin(1 To Arg7.Count): J = 0: ReDim TS1(-1 To -1)
               For Each Arg1 In Arg7.Co
                  TS2 = Split(Arg1.Id, "-")
                  For P = 0 To UBound(TS2) - 1: TS2(P) = TS2(P) & "-": Next P
                  For P = 0 To UBound(TS1): If P >= UBound(TS2) Then Exit For
                     If TS2(P) <> TS1(P) Then Exit For
                     Next P
                  Nom = "": While P <= UBound(TS2): Nom = Nom & TS2(P): P = P + 1: Wend
                  J = J + 1: TJoin(J) = Nom: TS1 = TS2: Next Arg1
               L = L + 1: TRes(L, 1) = TTit(1, 1): TRes(L, 2) = Join(TJoin, ".")
               L = L + 1: TRes(L, 1) = TTit(1, 2): TRes(L, 2) = Arg2.Id: If Arg2.Id > 200 Then TRes(L, 3) = 1
               L = L + 1: TRes(L, 1) = TTit(1, 3): TRes(L, 2) = Arg3.Id: If Arg3.Id > 25 Then TRes(L, 3) = 1
               L = L + 1: TRes(L, 1) = TTit(1, 4): TRes(L, 2) = Arg4.Id: If Arg4.Id = 2150 Then TRes(L, 3) = 1
               L = L + 1: TRes(L, 1) = TTit(1, 7): TRes(L, 2) = Arg7.Id
               TRes(L + 1, 1) = TTit(1, 5)
               For Each Arg1 In Arg7.Co
                  For Each Detail In Arg1.Co
                     C = L + Dico6(Detail(6)): TRes(C, 2) = TRes(C, 2) + Detail(5)
                     Next Detail, Arg1
               For C = LBound(TCoul) To UBound(TCoul)
                  L = L + 1: TRes(L, 3) = TCoul(C)
                  Next C, Arg7, Arg4, Arg3
      L = L + 1: Next Arg2
   RngCbl.Value = TRes
   On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants, 1)
   If Err = 0 Then
      RngCbl.Offset(, -1).Font.Color = &HFF&
      RngCbl.ClearContents: End If
   End Sub
Le 品名 du paquet est reproduit dans une nouvelle ligne, juste après le 長さ
 

anri0610

XLDnaute Junior
Bonjour, 
merci beaucoup! j'etait en train de tester et étudier de quelle manière il aurait fallu s'y prendre,
un petit peu compliquer a comprendre surtout dans les finitions de votre codage mais merci encore,
c'est encore loin de mes compétences d'arriver a une réflexion de la sorte !

Cependant avec cet emplacement ça ne va pas car le plus important dans ces regroupement est de garder intacte la colonne I, sans lui ajouter de valeur ou encore de ligne supplémentaire ! ( je copie les données de haut en bas tel quelles par la suite)
il serait nécessaire de basculer ce résultat sur la colonne J, dans ce cas la le ''品名'' serait
inutile.

J'essaye de trouver par moi même comment déplacer ce résultat pour l'instant ! :)
je vous joint un print screen qui je pense sera plus clair !
le remplissage en jaune indiquant l'emplacement et la forme que je souhaiterais obtenir.

PS: Je suis parvenu pour l'instant a décaler sur la droite en modifier cela ! :

VB:
               L = L + 1: TRes(L, 1) = TTit(1, 7): TRes(L, 3) = Arg7.Id


UP!!
Je pense avoir trouve !!
est ce bien comme cela ?

VB:
               L = L + 0: TRes(L, 1) = TTit(1, 6): TRes(L, 3) = Arg7.Id
 

Fichiers joints

Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonjour.
En gros oui si ça vous arrange mieux pourquoi pas, mais à quoi ça sert d'ajouter 0 à L ? Inutile si vous souhaitez rester sur la même ligne !
J'aurais même plutôt mis dans cas seulement la dernière instruction à la place de celle qui y mettait 1 s'il fallait le Font.Color = &HFF& après puisque apparemment elle ne sert plus à rien.

Mais pourquoi vous copiez ça ? Pour le coller où ? Tout en une fois ? Ou bien au final il s'avère que tout ça ne sert à rien parce qu'en fait c'est dans le presse-papier qu'il aurait plutôt été intéressant d'envoyer tout ça et non dans des cellules ?
 
Dernière édition:

anri0610

XLDnaute Junior
Bonjour,

Oui effectivement +0 ne sert a rien, pour le font color j'ai essayer a de nombreuses reprise
mais en fait il ne fonctionne pas pour le regroupement,
si par exemple je met en violet même toute la colonne C, la couleur ne sera pas reportée dans les regroupements...
ce qui est dommage car si je met une règle dans la colonne I des regroupement cela affectera bien sur toutes les données ..

Ces regroupement je les copies dans un logiciel CAD, rassurez vous tout ce qui est fait dans votre programme est totalement nécessaire, je copie chaque regroupement un par un selon les données et selon les cas plusieurs d'un coup, d'ou le besoin du respect des lignes sautées entre les regroupement :)
Tout est je pense parfait a part le font color qui ne s'exporte pas, car ensuite tout dépends de l'analyse humaine dans le travail.

Je ne sais pourquoi mais après chaque utilisation des macros en fermant les fichier on me demande si je veux enregistrer les modifications du classeur de macros, est ce normal ?

Je vous remercie encore infiniment c'est un bonheur d'arriver a un
résultat en programmation, une expérience grâce a vous vraiment enrichissante !
merci!

J'aurais un autre sujet auquel je souhaiterai savoir si c'est possible et j'aimerai interroger le forum, mais je suis mal a l'aise de dépendre a ce point de l'aide de tout le monde..
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Ce que j'avais plus ou moins en tête, en gros, c'est une procédure qui au lieu d'envoyer tout dans des cellules enverrait chaque paquet dans le presse papier (ce qui revient à un Ctrl+C d'un texte) puis un MsgBox, reproduisant, pour info visuelle le contenu envoyé, permettrait d'avaliser par son bouton OK que le Ctrl+V vers un autre logiciel à été fait, avant d'y envoyer le paquet suivant. Ça pourrait économiser les manœuvres de copie, seuls les collages resteraient à faire.
 

anri0610

XLDnaute Junior
Tres bonne idée! , a tester mais seulement comme le choix de copie peut être de plusieurs regroupements je ne sais pas si ça resterait productif, puisqu'il faudrait tout de même définir ce que l on veut copier a chaque fois,

cela dit ayant essayer de copier plusieurs sélections distinctes et les coller,
ça ne fonctionne pas et cela copie tout de la première sélection a la dernière (colonne I).
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Si on ne peut pas fixer de règle automatique, évidemment …
Si on pouvait, seule la colonne I serait à copier ?
Curieux qu'on puisse copier plusieurs groupes en même temps. C'est collé dans quoi, dans une sorte d'image de ficher texte et non dans des champs de saisie ? Le logiciel n'a-t-il pas la possibilité de saisir des infos d'un fichier texte d'ailleurs, justement ? Parce qu'en VBA ou peut aussi écrire dans un fichier texte. Il faudrait juste connaître la forme exacte à respecter.
 
Dernière édition:

anri0610

XLDnaute Junior
Bonjour,

Merci pour votre réponse,
Je pense que rester sur excel pour avoir un mouvement de modification possible reste le plus intéressant pour la suite,
par contre le problème de copie vient des données copiées par excel je pense.
je vous joint le print screen.

Pourriez vous me dire pourquoi le font color ne s'exporte pas dans les regroupements ?
et pourquoi après chaque utilisation des macros en fermant le classeur on me demande si je veux enregistrer les modifications du classeur de macros ?
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonjour.
Parce que le traitement ne porte que sur les valeurs des cellules, pas sur leurs formats.
Je ne sais pas pourquoi Excel perçoit que votre classeur de macro a été modifié quand vous le fermez.
 

Discussions similaires


Haut Bas