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

N

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
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour le forum,
netparty à dit:
Merci pour cette adaptation et est-il possible d'avoir le résultat dans une nouvelle feuille ?
Cliquez pour agrandir...
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
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
N

netparty

XLDnaute Occasionnel
job75 à dit:
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
Cliquez pour agrandir...
Bonjour @job75

Merci
 
Vote positif 0 Vote négatif
mapomme

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:
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
N

netparty

XLDnaute Occasionnel
JHA à dit:
Bonjour à tous,

Avec Power Query et une concatenation

JHA
Cliquez pour agrandir...
Bonjour @JHA

J'aimerais adapter le fichier pour compter les longueurs total comment puis-je adapter le fichier pour cela
Cousinhub à dit:
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
Cliquez pour agrandir...
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
Vote positif 0 Vote négatif
Cousinhub

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
 
Vote positif 0 Vote négatif
N

netparty

XLDnaute Occasionnel
Cousinhub à dit:
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
Cliquez pour agrandir...
@Cousinhub

Super
Un tout grand merci

Bonne journée
 
Vote positif 0 Vote négatif
job75

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
Vote positif 0 Vote négatif
N

netparty

XLDnaute Occasionnel
job75 à dit:
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+
Cliquez pour agrandir...
Bonjour @job75

Merci pour cette adaptation c'est parfait

Bonne journée
 
Vote positif 0 Vote négatif

Discussions similaires

L
  • Question
Microsoft 365 Créer un tarif multi entrées Excel
Réponses
5
Affichages
170
Efgé
Efgé
F
  • Question
XL 2016 Compter les valeurs uniques dans une liste
Réponses
3
Affichages
165
F22Raptor
F
A
  • Question
Microsoft 365 NB.SI selon plusieurs critères
Réponses
3
Affichages
168
al.db
A
S
  • Question
Microsoft 365 renvoyer dernier mois ou les quantites ont changees
2
Réponses
18
Affichages
624
STEPHANIE1975
S
B
  • Question
Microsoft 365 Bon de commande avec recapitulatif des lignes saisies sur une autre feuille
Réponses
1
Affichages
263
djidji59430
djidji59430
Y
  • Question
XL 2013 TCD - Calculer les données d'une colonne à l'aide d'une variable, ligne par ligne
Réponses
3
Affichages
359
chris
chris
Usine à gaz
  • Résolu(e)
XL 2021 Compter le nombre de cellules qui contiennent la date d'aujourd'hui
2
Réponses
17
Affichages
812
job75
job75
P
  • Question
XL 2016 Recherche et somme de plusieurs critères
Réponses
2
Affichages
178
JHA
J
E
  • Question
XL pour MAC petit calcul matriciel....
Réponses
8
Affichages
336
Dranreb
Dranreb
L
  • Question
Microsoft 365 Comparer 2 TCD en créant un 3 ème
Réponses
4
Affichages
231
lilie91
L

Membres actuellement en ligne

3 membres et 34 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 685
Messages
2 090 941
Membres
104 703
dernier inscrit
romla937