Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 Compter des quantités sur plusieurs critères

  • Initiateur de la discussion Initiateur de la discussion netparty
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

netparty

XLDnaute Occasionnel
Bonjour à tous
Je cherche le moyen de compter la quantités de matériel en regroupant les modèles identiques.
Auriez-vous une idée pour la formule à utiliser.

Merci d'avance
 

Pièces jointes

Bonjour le forum,
Merci pour cette adaptation et est-il possible d'avoir le résultat dans une nouvelle feuille ?
Il suffit de copier la plage filtrée :
VB:
Sub Unique()
Dim F As Worksheet, d As Object, i&, x$
Set F = Sheets("Unique") 'à adapter
Set d = CreateObject("Scripting.Dictionary")
With [A1].CurrentRegion.Resize(, 30)
ReDim resu(1 To .Rows.Count, 1 To 1)
resu(1, 1) = "Quantité"
    For i = 2 To .Rows.Count
        x = .Cells(i, 6) & .Cells(i, 16) & .Cells(i, 18)
        If x <> "" And Not d.exists(x) Then d(x) = i
        resu(d(x), 1) = resu(d(x), 1) + 1
    Next
    .AutoFilter
    .Columns(30) = resu
    .AutoFilter 30, ">0"
    F.Cells.Delete 'RAZ
    .Copy F.[A1] 'copier-coller
    F.Columns.AutoFit 'ajustement largeurs
    .Columns(30) = ""
    .AutoFilter 'ôte le filtre
    Application.Goto F.[A1], True 'cadrage
End With
End Sub
A+
 

Pièces jointes

Pas besoin de bouton, activez la feuille "Unique" :
VB:
Private Sub Worksheet_Activate()
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1").[A1].CurrentRegion.Resize(, 30)
ReDim resu(1 To .Rows.Count, 1 To 1)
resu(1, 1) = "Quantité"
    For i = 2 To .Rows.Count
        x = .Cells(i, 6) & .Cells(i, 16) & .Cells(i, 18)
        If x <> "" And Not d.exists(x) Then d(x) = i
        resu(d(x), 1) = resu(d(x), 1) + 1
    Next
    Application.ScreenUpdating = False
    .AutoFilter
    .Columns(30) = resu
    .AutoFilter 30, ">0"
    Cells.Delete 'RAZ
    .Copy [A1] 'copier-coller
    Columns.AutoFit 'ajustement largeurs
    .Columns(30) = ""
    .AutoFilter 'ôte le filtre
    Application.Goto [A1], True 'cadrage
End With
End Sub
 

Pièces jointes

Bonjour @job75

Merci
 
Bonsoir à tous 🙂 ,

Juste pour le fun, une version par macro sans utiliser de dictionary. Le code est à placer dans le module de la feuille destinée au résultat :
VB:
Private Sub Worksheet_Activate()
' 2 paramètres : nom de la feuille source - liste des 3 colonnes (lettres)
Const FeuilSource = "Feuil1", colonnes = "A F H"
Dim cols, wksSource As Worksheet, der&, x, i&, t, i0&, n&
   Application.ScreenUpdating = False: cols = Split(colonnes): Set wksSource = Sheets(FeuilSource)
   With Me
      .Columns("a:d").Clear
      For Each x In Split(colonnes): i = i + 1: wksSource.Range(x & 1).EntireColumn.Copy .Columns(i): Next
      der = .Cells(Rows.Count, 1).End(xlUp).Row
      With .Range("a1").Resize(der, 4)
         .Sort key1:=[a1], order1:=1, key2:=[b1], order2:=1, key3:=[c1], order3:=1, Header:=1, MatchCase:=False
         t = .Value
      End With
      t(1, 4) = "Qté": i0 = 2: n = 1
      For i = 2 To UBound(t)
         If t(i, 1) <> t(i0, 1) Or t(i, 2) <> t(i0, 2) Or t(i, 3) <> t(i0, 3) Then
            n = n + 1: t(n, 4) = i - i0
            t(n, 1) = t(i0, 1): t(n, 2) = t(i0, 2): t(n, 3) = t(i0, 3)
            i0 = i
         End If
      Next i
      If t(i0, 1) & t(i0, 2) & t(i0, 3) <> "" Then
         n = n + 1: t(n, 4) = i - i0
         t(n, 1) = t(i0, 1): t(n, 2) = t(i0, 2): t(n, 3) = t(i0, 3)
      End If
      .Columns("a:d").Clear
      With .Range("a1").Resize(n, 4)
         .Value = t: .Borders.LineStyle = xlContinuous: .Columns.AutoFit
         .Rows(1).Font.Bold = True: .Rows(1).Interior.Color = RGB(220, 250, 220)
      End With
   End With
End Sub
 

Pièces jointes

Dernière édition:
Bonjour netparty; le forum,

Voici une solution plus rapide :
VB:
Private Sub Worksheet_Activate()
Dim d As Object, tablo, resu(), i&, x$, n&, j%, nn&
Set d = CreateObject("Scripting.Dictionary")
tablo = Sheets("Feuil1").[A1].CurrentRegion.Resize(, 29) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 30)
For i = 1 To UBound(tablo)
    x = tablo(i, 6) & tablo(i, 16) & tablo(i, 18)
    If x <> "" Then
        If Not d.exists(x) Then
            n = n + 1
            d(x) = n
            For j = 1 To 29: resu(n, j) = tablo(i, j): Next j
        End If
        nn = d(x)
        resu(nn, 30) = resu(nn, 30) + 1
    End If
Next i
resu(1, 30) = "Quantité"
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
If n = 0 Then Exit Sub
[A1].Resize(n, 30) = resu
Rows(1).Font.Bold = True
Columns(30).HorizontalAlignment = xlCenter
Columns.AutoFit 'ajustement largeurs
End Sub
Pour tester j'ai recopié le tableau source sur 86 000 lignes :

- macro du post #18 => 1,56 seconde

- macro du post #21 de mapomme => 0,70 seconde

- cette macro => 0,40 seconde.

A+
 

Pièces jointes

Bonjour à tous,

Avec Power Query et une concatenation

JHA
Bonjour @JHA

J'aimerais adapter le fichier pour compter les longueurs total comment puis-je adapter le fichier pour cela
Bonjour @Cousinhub
J'aimerais adapter le fichier pour compter les longueurs total comment puis-je adapter le fichier pour cela.
Merci d'avance
Bonne journée
 

Pièces jointes

Bonjour,
Clic dans une cellule de la requête (Cellule F1, par exemple)
Dans l'éditeur PQ (pour ouvrir l'éditeur sous 365, tu peux faire Alt + F12)
Ruban "Accueil", tu cliques sur "Éditeur avancé", tu vois ce code :
PowerQuery:
let
    Source = Excel.CurrentWorkbook(){[Name="T_Data"]}[Content],
    GroupBy = Table.Group(Source, T_Crit[Titre], {{"Nombre", each Table.RowCount(_), Int64.Type}})
in
    GroupBy
Ici, on ne calcule donc que le nombre.
Pour rajouter la longueur totale, remplace tout ce code par :
PowerQuery:
let
    Source = Excel.CurrentWorkbook(){[Name="T_Data"]}[Content],
    GroupBy = Table.Group(Source, T_Crit[Titre], {{"Nombre", each Table.RowCount(_), Int64.Type},{"Longueur totale", each List.Sum([LONGUEUR]), type number}})
in
    GroupBy
Puis "OK", et "Fermer et charger"
Une nouvelle colonne va s'ajouter, avec la longueur totale de tes choix
Reviens, si tu n'y arrives pas
 
@Cousinhub

Super
Un tout grand merci

Bonne journée
 
Bonjour netparty; Cousinhub, le forum,

Si je comprends bien il faut que la colonne Z (26) soit renseignée et totalisée :
VB:
Private Sub Worksheet_Activate()
Dim d As Object, tablo, resu(), i&, x$, nn&, v, n&, j%
Set d = CreateObject("Scripting.Dictionary")
tablo = Sheets("Feuil1").[A1].CurrentRegion.Resize(, 29) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 30)
For i = 1 To UBound(tablo)
    x = tablo(i, 6) & tablo(i, 16) & tablo(i, 18)
    If x <> "" Then
        If d.exists(x) Then
            nn = d(x)
            v = tablo(i, 26) 'en colonne Z
            If IsNumeric(CStr(v)) Then resu(nn, 26) = resu(nn, 26) + v 'Longueur totale
            resu(nn, 30) = resu(nn, 30) + 1 'Quantité
        Else
            n = n + 1
            d(x) = n
            For j = 1 To 29: resu(n, j) = tablo(i, j): Next j
            If i > 1 And Not IsNumeric(resu(n, 26)) Then resu(n, 26) = Empty 'colonne Z
            resu(n, 30) = 1
        End If
    End If
Next i
resu(1, 30) = "Quantité"
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
If n = 0 Then Exit Sub
[A1].Resize(n, 30) = resu
Rows(1).Font.Bold = True
Columns(30).HorizontalAlignment = xlCenter
Columns.AutoFit 'ajustement largeurs
End Sub
A+
 

Pièces jointes

Bonjour @job75

Merci pour cette adaptation c'est parfait

Bonne journée
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
5
Affichages
125
Réponses
16
Affichages
532
Réponses
5
Affichages
420
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…