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

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

  • Total des types.xlsm
    9.6 KB · Affichages: 14

job75

XLDnaute Barbatruc
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

  • Total des types-Job75.xlsm
    20.2 KB · Affichages: 1

job75

XLDnaute Barbatruc
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

  • Total des types-Job75.xlsm
    18.6 KB · Affichages: 5

netparty

XLDnaute Occasionnel
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
Bonjour @job75

Merci
 

mapomme

XLDnaute Barbatruc
Supporter XLD
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

  • netparty- Total des types- v1.xlsm
    22.6 KB · Affichages: 2
Dernière édition:

job75

XLDnaute Barbatruc
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

  • Total des types-Job75.xlsm
    19.3 KB · Affichages: 4

netparty

XLDnaute Occasionnel
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,
Une solution à base de Power Query (plus un code VBA pour actualiser).
Dans l'onglet "Base", ta base de données sous forme de Tableau Structuré, et nommé "T_Data"
Dans l'onglet "Recap", à gauche, tous les titres de ta base de données en colonne A (à bien renseigner - un Copier/Coller, recopie "Transposée", pour avoir une concordance exacte des titres)
En colonne B, tu choisis les filtres (données) dont tu veux calculer les types de manière unique (une validation des données te permet de choisir le X)
Le bouton "Actualiser"
Et le Tableau "T_Final", qui te donne les nombres uniques selon tes choix...
Bon dimanche
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

  • PQ_Total des types.xlsm
    29.5 KB · Affichages: 1

Cousinhub

XLDnaute Barbatruc
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
 

netparty

XLDnaute Occasionnel
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
 

job75

XLDnaute Barbatruc
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

  • Total des types-Job75.xlsm
    20.5 KB · Affichages: 4

netparty

XLDnaute Occasionnel
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+
Bonjour @job75

Merci pour cette adaptation c'est parfait

Bonne journée
 

Discussions similaires

Statistiques des forums

Discussions
313 212
Messages
2 096 249
Membres
106 544
dernier inscrit
seifel