[Résolu par Mapomme] Rassembler les valeurs pour chaque référence

Webperegrino

XLDnaute Impliqué
Supporter XLD
Bonsoir le Forum,
Dans le fichier ci-joint j’ai un pavé B8:F20000 dans lequel je voudrais faire un regroupement.

Il y a bien une "solution 1" que j'ai appliquée.
Toutefois elle ne me convient pas car elle sera "mangeuse d'octets" avec les formules placées dans la base, surtout si je saisi jusqu’à 20 000 lignes…

Pouvez-vous m’aider à trouver une formulation VBA permettant de « nettoyer » ce pavé de cellules après chaque saisie pour donner un final similaire à ce que j’ai placé pour l’exemple en partie droite de la feuille ?

L’objectif étant de créer une macro rapide et limitée en lignes.
Les cellules recevraient des totaux sans formules.

La formulation VBA sous forme de "Tablo" m’est encore ardue en langage VBA.

Merci pour vos offres.
Cordialement,
Webperegrino
 

Pièces jointes

  • Regouper et additionner.xls
    31 KB · Affichages: 57
Dernière édition:

Webperegrino

XLDnaute Impliqué
Supporter XLD
Re : Rassembler les valeurs pour chaque référence

Le Forum,
J'ai tenté ceci :

VB:
Private Sub CommandButton1_Click()

With Sheets("Feuil1")
Set Plage = .Range(.Cells(8, 2), .Cells(.Rows.Count, 6).End(xlUp))
Plage.Sort Columns(2), 1
j = 8
For i = 8 To Plage.Rows.Count
k = k + Application.CountIf(Plage.Columns(2), Plage.Columns(2).Cells(i, 6))
'jusque-là tout fonctionne, les lignes s'ordonnent dans l'ordre croissant colonne B

Exit Sub

' Ici je suis perdu : la suite donne un massacre
j = j + 1
.Cells(j, 1) = Plage.Columns(2).Cells(i, 2)
.Cells(j, 2) = Application.Sum(.Range("C" & i + 1 & ":C" & k + 1))
.Cells(j, 3) = Application.Sum(.Range("D" & i + 1 & ":D" & k + 1))
.Cells(j, 4) = Application.Sum(.Range("E" & i + 1 & ":E" & k + 1))
.Cells(j, 5) = Application.Sum(.Range("F" & i + 1 & ":F" & k + 1))
i = k
Next i
End With
End Sub

Cordialement,
Webperegrino
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Rassembler les valeurs pour chaque référence

Bonsoir Webperegrino,

Voir un essai dans le fichier joint (réalisé sous Excel 2010 et sauvegardé sous le format Excel 2003):
VB:
Private Sub CommandButton1_Click()
Dim derlig1&, derlig2&

  Application.ScreenUpdating = False
  derlig1 = Cells(Rows.Count, "b").End(xlUp).Row
  If derlig1 <= 7 Then Exit Sub
  
  Range("b8:f" & derlig1).Sort Range("b7"), xlAscending, Header:=xlYes
  Range("b" & derlig1 + 2).Consolidate Sources:= _
    Range("b8:f" & derlig1).Address(True, True, xlR1C1, True) _
    , Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
  derlig2 = Cells(Rows.Count, "b").End(xlUp).Row
  Range("b" & derlig1 + 2 & ":f" & derlig2).Copy
  Range("b8").PasteSpecial xlPasteValues
  Range("b" & 7 + (derlig2 - derlig1) & ":f" & derlig2).ClearContents
End Sub

Erratum : Une petite coquille à corriger -> remplacer dans le code Header:=xlYes par Header:=xlNo.
 

Pièces jointes

  • Webperegrino-Regouper et additionner-v1.xls
    36 KB · Affichages: 64
Dernière édition:

Webperegrino

XLDnaute Impliqué
Supporter XLD
Re : Rassembler les valeurs pour chaque référence

Bonsoir Le Forum,
Bonsoir-Bonjour Mapomme,
Ça semble parfait : il me faut maintenant vérifier que dans ma réelle application cela sera bien appliqué.
Le fichier #3 fonctionne très bien.
J'ai ajouté une ligne 19 avec du 4056 et k19= 7 : la macro me donne bien ce total à 14.
Magnifique, merci,
Je vais maintenant, par comparaison avec la vôtre, voir où cela ne marchait pas dans ma précédente programmation
Cordialement
Webperegrino
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Rassembler les valeurs pour chaque référence

Bonjour Webperegrino :),

Une petite coquille :mad:dans mon premier code. La valeur du paramètre de tri Header doit être xlNo (et non xlYes) faute de quoi la première ligne du tableau n'est pas incluse dans le tri.

Une précision, je n'utilise pas de "tablo" mais la fonction "Consolider" d'Excel qui fait très bien le travail.
 

Webperegrino

XLDnaute Impliqué
Supporter XLD
Re : Rassembler les valeurs pour chaque référence

Le Forum,
Mapomme, Bonjour,
Merci pour cette dernière précision : je n'avais pas vu cette anomalie lors de l'affichage du résultat.
Intéressant pour moi de faire les deux comparaisons... pour apprendre le déroulement de vos lignes VBA.
Merci encore pour votre précieuse aide,
Bonne journée à vous,
Webperegrino

Ps : Mapomme, je viens d'appliquer les deux possibilités séparément (yes, puis xlno) mais le résultat me semble identique, en tout cas en ce qui concerne ce que je lis à l'écran.
Je place toutefois "xlno" sur vos recommandations.
 
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Rassembler les valeurs pour chaque référence

re :),

(...) je viens d'appliquer les deux possibilités séparément (yes, puis xlno) mais le résultat me semble identique, en tout cas en ce qui concerne ce que je lis à l'écran.
Je place toutefois "xlno" sur vos recommandations.

Si la première ligne (ligne 8) de vos données comporte une clef qui n'est pas le minimum des clefs, alors vous verrez que cette première ligne reste la première ligne dans le résultat et n'est donc pas à sa place (avec xlYes).
 

Modeste geedee

XLDnaute Barbatruc
Re : [Résolu par Mapomme] Rassembler les valeurs pour chaque référence

Bonsour®

sans formule, sans macro
Capture.JPG
avec un TCD !!!

mais aussi sans cellules fusionnées...
:(
 

Pièces jointes

  • Capture.JPG
    Capture.JPG
    31.8 KB · Affichages: 42
  • regouper-et-additionner.xls
    67.5 KB · Affichages: 44

laetitia90

XLDnaute Barbatruc
Re : [Résolu par Mapomme] Rassembler les valeurs pour chaque référence

bonsoir tous :):):)

une version dico pour faire le tour du pb..

Code:
Sub es()
 Dim t(), i As Long, m As Object, c As Byte, x as long
 Set m = CreateObject("Scripting.Dictionary")
 t = Range("b8:f" & Cells(Rows.Count, 2).End(3).Row)
 For i = 1 To UBound(t)
 If m.Exists(t(i, 1)) Then
 For c = 2 To 5:  t(m(t(i, 1)), c) = t(m(t(i, 1)), c) + t(i, c): Next c
 Else
 x = x + 1
 For c = 1 To 5: t(x, c) = t(i, c): Next c:   m(t(i, 1)) = x
 End If
 Next i
 Range("b8:f" & Cells(Rows.Count, 2).End(3).Row).ClearContents
 [b8].Resize(x, 5) = t
 Range("b8:f" & Cells(Rows.Count, 2).End(3).Row).Sort [b8], xlAscending, Header:=0
End Sub
 

Statistiques des forums

Discussions
311 720
Messages
2 081 912
Membres
101 837
dernier inscrit
Ugo