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
Inactif
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

N
  • Question
Microsoft 365 Récapitulatif sommes des quantités
Réponses
2
Affichages
169
C'est papy Mougeot !
C'est papy Mougeot !
misteryann
  • Question
XL 2016 Adapter un code à mon fichier (RESOLU)
Réponses
4
Affichages
152
misteryann
misteryann
B
  • Question
XL 2016 VBA et valeur cible sur cellules différentes
Réponses
3
Affichages
183
Lolote83
L
cp4
  • Résolu(e)
XL 2010 Compter Avec NB.SI.ENS Listobject
2
Réponses
23
Affichages
746
cp4
cp4
O
  • Résolu(e)
XL 2013 Formule ou Codage VBA qui met à jour un tableau en fonction de quantité
Réponses
5
Affichages
189
onyirimba
O
AIXELS
  • Question
Autres Copie de données (message d'erreur)
Réponses
3
Affichages
99
AIXELS
AIXELS
S
  • Question
XL pour MAC Compter des cellules colorées en ligne
Réponses
2
Affichages
289
sabinette37
S
T
  • Question
Microsoft 365 Croiser des information tableau de données
Réponses
3
Affichages
220
Toucan72
T
Océane
  • Question
XL 2019 Compter des cellules trier
Réponses
1
Affichages
188
Lolote83
L
S
  • Résolu(e)
Microsoft 365 Formule
Réponses
9
Affichages
299
StéphNanie
S

Membres actuellement en ligne

5 membres et 43 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
314 738
Messages
2 112 339
Membres
111 513
dernier inscrit
jeanmarty