XL 2016 Additionner les quantités et supprimer les lignes en trop

[BPM]

Bonjour à tous,

Je viens solliciter votre aide pour un problème, j'ai un tableau dans lequel il y a 3 colonnes principales avec le nombre de ligne est variable en fonction du document; le code que je voudrais est qu'il puisse additionner les quantités des éléments c'est à dire que dans la colonne B il y a le nom des articles et dans la colonne D les quantités de chaque article, si dans la colonne B le mot "archive" par exemple apparait plusieurs fois sur 5 lignes et que chaque ligne a une quantité donnée que le code puisse additionner les quantités lu dans chaque ligne et qu'il puisse supprimer les autres en gardant qu'une seule ligne archive avec le nombre total dans la quantité le résultat de l'addition par exemple 5 donc ce qui fera qu'il n'y aura qu'une seule ligne avec le mot archive dans la colonne B et 5 dans la colonne D.
Il y a une petite précision par exemple si l'article qui se répète plusieurs dans la colonne B et que dans la colonne D à chaque fois c'est écrit quantité 0 il faudrait que le code supprime toutes les autres lignes et en garde qu'une seule avec la quantité 0.
J'espère que c'est assez claire comme explication, je joins un petit document exemple. merci d'avance pour votre aide.

 

[Dranreb]

Bonjour.
Cette macro le fait :

Option Explicit
Sub Grouper()
   Dim RDon As Range, TEntrée(), Le&, LeDéb&, TSortie(), Ls&, C As Byte
   With Feuil1.UsedRange: Set RDon = .Rows(2).Resize(.Rows.Count - 1): End With
   TEntrée = RDon.Value
   ReDim TSortie(1 To UBound(TEntrée, 1), 1 To UBound(TEntrée, 2))
   Le = 1
   Do While Le <= UBound(TEntrée, 1)
      LeDéb = Le
      Do: Le = Le + 1: If Le > UBound(TEntrée, 1) Then Exit Do
         If TEntrée(Le, 1) <> TEntrée(LeDéb, 1) Or TEntrée(Le, 2) <> TEntrée(LeDéb, 2) Then Exit Do
         TEntrée(LeDéb, 3) = TEntrée(LeDéb, 3) + TEntrée(Le, 3): Loop
      If TEntrée(LeDéb, 3) <> 0 Then
         Ls = Ls + 1
         For C = 1 To 3: TSortie(Ls, C) = TEntrée(LeDéb, C): Next C
         End If
      Loop
   RDon.Value = TSortie
   End Sub

 

[BPM]

Bonjour.
Cette macro le fait :

Option Explicit
Sub Grouper()
   Dim RDon As Range, TEntrée(), Le&, LeDéb&, TSortie(), Ls&, C As Byte
   With Feuil1.UsedRange: Set RDon = .Rows(2).Resize(.Rows.Count - 1): End With
   TEntrée = RDon.Value
   ReDim TSortie(1 To UBound(TEntrée, 1), 1 To UBound(TEntrée, 2))
   Le = 1
   Do While Le <= UBound(TEntrée, 1)
      LeDéb = Le
      Do: Le = Le + 1: If Le > UBound(TEntrée, 1) Then Exit Do
         If TEntrée(Le, 1) <> TEntrée(LeDéb, 1) Or TEntrée(Le, 2) <> TEntrée(LeDéb, 2) Then Exit Do
         TEntrée(LeDéb, 3) = TEntrée(LeDéb, 3) + TEntrée(Le, 3): Loop
      If TEntrée(LeDéb, 3) <> 0 Then
         Ls = Ls + 1
         For C = 1 To 3: TSortie(Ls, C) = TEntrée(LeDéb, C): Next C
         End If
      Loop
   RDon.Value = TSortie
   End Sub

Merci beaucoup pour cette première solution, mais deux petits soucis le premier est que pour les éléments qui sont en quantité 0 faut pas tout supprimer par exemple dans mon tableau il y a dans la colonne B l'article "traités" répété sur 3 lignes avec dans la colonne en quantité "0" l'idée est de supprimer 2lignes et de n'en garder qu'une seule avec dans la colonne B "traités" et dans la colonne D "0"; et le deuxième souci est qu'il ne faut pas prendre en compte la colonne C juste les colonnes B et D pour regrouper les articles, parce que les désignations dans la colonne C peuvent être différentes mais ce n'est pas primordiales.
j'espère que vous comprenez un peu mes soucis, merci encore pour votre temps.

 

[Dranreb]

Alors supprimez la 2nde partie 'Or TEntrée(Le, 2) <> TEntrée(LeDéb, 2)' du test
ainsi que le 'If TEntrée(LeDéb, 3) <> 0 Then' et le 'End If' correspondant.
Mais vous n'auriez pas du laisser entendre qu'il y avait un traitement spécial dans le cas ou la quantité était à 0

 

[BPM]

Alors supprimez la 2nde partie 'Or TEntrée(Le, 2) <> TEntrée(LeDéb, 2)' du test
ainsi que le 'If TEntrée(LeDéb, 3) <> 0 Then' et le 'End If' correspondant.
Mais vous n'auriez pas du laisser entendre qu'il y avait un traitement spécial dans le cas ou la quantité était à 0

Je vous joins un autre fichier avec à côté le résultat souhaité pour vous aider à mieux comprendre l'idée du code que je souhaite.
merci encore pour votre temps.

 

[Dranreb]

Effectuez les modifications que je vous ai indiquées.

 

[BPM]

avec les modifications que vous avez indiquées le code devient :
Option Explicit
Sub Grouper()
Dim RDon As Range, TEntrée(), Le&, LeDéb&, TSortie(), Ls&, C As Byte
With Feuil1.UsedRange: Set RDon = .Rows(2).Resize(.Rows.Count - 1): End With
TEntrée = RDon.Value
ReDim TSortie(1 To UBound(TEntrée, 1)
Le = 1
Do While Le <= UBound(TEntrée, 1)
LeDéb = Le
Do: Le = Le + 1: If Le > UBound(TEntrée, 1) Then Exit Do
If TEntrée(Le, 1) <> TEntrée(LeDéb, 1) Then Exit Do
TEntrée(LeDéb, 3) = TEntrée(LeDéb, 3) + TEntrée(Le, 3): Loop
Loop
RDon.Value = TSortie
End Sub

c'est bien cela ?

 

[Dranreb]

Utilisez le bouton '</>' sur ce site pour citer du code.
Ça donne ça :

Option Explicit
Sub Grouper()
   Dim RDon As Range, TEntrée(), Le&, LeDéb&, TSortie(), Ls&, C As Byte
   With Feuil1.UsedRange: Set RDon = .Rows(2).Resize(.Rows.Count - 1, 3): End With
   TEntrée = RDon.Value
   ReDim TSortie(1 To UBound(TEntrée, 1), 1 To UBound(TEntrée, 2))
   Le = 1
   Do While Le <= UBound(TEntrée, 1)
      LeDéb = Le
      Do: Le = Le + 1: If Le > UBound(TEntrée, 1) Then Exit Do
         If TEntrée(Le, 1) <> TEntrée(LeDéb, 1) Then Exit Do
         TEntrée(LeDéb, 3) = TEntrée(LeDéb, 3) + TEntrée(Le, 3): Loop
      Ls = Ls + 1
      For C = 1 To 3: TSortie(Ls, C) = TEntrée(LeDéb, C): Next C
      Loop
   RDon.Value = TSortie
   End Sub

Vous en aviez trop supprimé: j'avais dit le 'If TEntrée(LeDéb, 3) <> 0 Then' et le 'End If' correspondant, mais pas les instructions qu'il y avait dedans et qui sont à exécuter systématiquement et plus seulement si le total n'est pas nul.

 

[BPM]

Utilisez le bouton '</>' sur ce site pour citer du code.
Ça donne ça :

Option Explicit
Sub Grouper()
   Dim RDon As Range, TEntrée(), Le&, LeDéb&, TSortie(), Ls&, C As Byte
   With Feuil1.UsedRange: Set RDon = .Rows(2).Resize(.Rows.Count - 1, 3): End With
   TEntrée = RDon.Value
   ReDim TSortie(1 To UBound(TEntrée, 1), 1 To UBound(TEntrée, 2))
   Le = 1
   Do While Le <= UBound(TEntrée, 1)
      LeDéb = Le
      Do: Le = Le + 1: If Le > UBound(TEntrée, 1) Then Exit Do
         If TEntrée(Le, 1) <> TEntrée(LeDéb, 1) Then Exit Do
         TEntrée(LeDéb, 3) = TEntrée(LeDéb, 3) + TEntrée(Le, 3): Loop
      Ls = Ls + 1
      For C = 1 To 3: TSortie(Ls, C) = TEntrée(LeDéb, C): Next C
      Loop
   RDon.Value = TSortie
   End Sub

Vous en aviez trop supprimé: j'avais dit le 'If TEntrée(LeDéb, 3) <> 0 Then' et le 'End If' correspondant, mais pas les instructions qu'il y avait dedans et qui sont à exécuter systématiquement et plus seulement si le total n'est pas nul.

D'accord, je comprends mieux merci à vous, je corrige et je test

 

[BPM]

Utilisez le bouton '</>' sur ce site pour citer du code.
Ça donne ça :

Option Explicit
Sub Grouper()
   Dim RDon As Range, TEntrée(), Le&, LeDéb&, TSortie(), Ls&, C As Byte
   With Feuil1.UsedRange: Set RDon = .Rows(2).Resize(.Rows.Count - 1, 3): End With
   TEntrée = RDon.Value
   ReDim TSortie(1 To UBound(TEntrée, 1), 1 To UBound(TEntrée, 2))
   Le = 1
   Do While Le <= UBound(TEntrée, 1)
      LeDéb = Le
      Do: Le = Le + 1: If Le > UBound(TEntrée, 1) Then Exit Do
         If TEntrée(Le, 1) <> TEntrée(LeDéb, 1) Then Exit Do
         TEntrée(LeDéb, 3) = TEntrée(LeDéb, 3) + TEntrée(Le, 3): Loop
      Ls = Ls + 1
      For C = 1 To 3: TSortie(Ls, C) = TEntrée(LeDéb, C): Next C
      Loop
   RDon.Value = TSortie
   End Sub

Vous en aviez trop supprimé: j'avais dit le 'If TEntrée(LeDéb, 3) <> 0 Then' et le 'End If' correspondant, mais pas les instructions qu'il y avait dedans et qui sont à exécuter systématiquement et plus seulement si le total n'est pas nul.

Merci à vous pour votre aide et votre temps, le code fonctionne très bien comme attendu.