XL 2010 Palmares de fabrication

V

viken76

XLDnaute Nouveau
Bonjour,

Je souhaiterai créer un palmarès des produits fabriqués à partir d'un listing des fabrications réalisées (cf.PJ) via une macro.

Ce palmarès doit intégrer exclusivement les 3 produits pour lesquels les quantités fabriqués sont les plus importantes.

Les cumuls des quantités fabriqués doivent être indiquées en colonne H.

Pourriez vous m'aider sur ce sujet svp ?

Merci d'avance,
 

Pièces jointes

  • test.xlsx
    8.8 KB · Affichages: 11
Trier par date Trier par votes
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Viken,
Un essai en PJ avec :
VB: 
Sub Compte()
Dim T(), DL%, L1%, L2%, Qté%, Nom$
Application.ScreenUpdating = False
' Taille tableau
DL = Range("A65500").End(xlUp).Row
' Tranfert dans array, plus raide
T = Range("B3:C" & DL)
' Cumul des quantités
For L1 = 1 To UBound(T)
    Nom = T(L1, 1)
    Qté = 0
    For L2 = L1 To UBound(T)
          If T(L2, 1) = Nom Then Qté = Qté + T(L2, 2)
    Next L2
    T(L1, 2) = Qté
Next L1
' Tri quantités décroissante
For L1 = 1 To UBound(T)
    For L2 = 1 To UBound(T)
        If T(L1, 2) > T(L2, 2) Then
            Nom = T(L1, 1): Qté = T(L1, 2)              ' Transfert Valeur 1
            T(L1, 1) = T(L2, 1): T(L1, 2) = T(L2, 2)    ' Swap Valeur1 valeur2
            T(L2, 1) = Nom: T(L2, 2) = Qté              ' Transfert Valeur 1 dans Valeur2
        End If
    Next L2
Next L1
' Suppression doublons
While (T(3, 1) = T(1, 1) Or T(3, 1) = T(2, 1)) Or T(2, 1) = T(1, 1)
    If T(3, 1) = T(1, 1) Or T(3, 1) = T(2, 1) Then T(3, 2) = 0
    If T(2, 1) = T(1, 1) Then T(2, 2) = 0
    ' Tri quantités décroissante
    For L1 = 1 To UBound(T)
        For L2 = 1 To UBound(T)
            If T(L1, 2) > T(L2, 2) Then
                Nom = T(L1, 1): Qté = T(L1, 2)              ' Transfert Valeur 1
                T(L1, 1) = T(L2, 1): T(L1, 2) = T(L2, 2)    ' Swap Valeur1 valeur2
                T(L2, 1) = Nom: T(L2, 2) = Qté              ' Transfert Valeur 1 dans Valeur2
            End If
        Next L2
    Next L1
Wend
' Transfert des 3 premiers
For L = 1 To 3
    Cells(5 + L, "G") = T(L, 1)
    Cells(5 + L, "H") = T(L, 2)
Next L
End Sub
 

Pièces jointes

  • test (25).xlsm
    17.9 KB · Affichages: 6
Dernière édition:
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re,
Si le nombre de lignes est élevé la macro précédente est lente.
En PJ un nouvel algo qui prend 66ms pour 1000 lignes avec :
VB: 
Sub Compte()
    Dim DL%
    Application.ScreenUpdating = False
    ' Taille de la liste
    DL = Cells(Rows.Count, "A").End(xlUp).Row
    ' Insére une colonne en Z
    Columns("Y:Y").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ' Copie formule en Z3
    Cells(3, "Z").FormulaR1C1 = _
    "=IF(COUNTIF(R1C2:RC[-24],RC[-24])=1,SUMIF(C[-24],RC[-24],C[-23])+(ROW()/10000),0)"
    ' La duplique sur toute la colonne
    Range(Cells(3, "Z"), Cells(DL, "Z")).FillDown
    ' Colle les valeurs
    Range(Cells(3, "Z"), Cells(DL, "Z")).Value = Range(Cells(3, "Z"), Cells(DL, "Z")).Value
    ' Met formule Qté
    Range("H6").Select
    ActiveCell.FormulaR1C1 = "=INT(LARGE(C[18],RC[-2]))"
    ' Met formule nom produit
    Range("G6").Select
    ActiveCell.FormulaR1C1 = "=INDEX(C[-5],MATCH(LARGE(C[19],RC[-1]),C[19],0))"
    ' Duplique formules
    Range("G6").AutoFill Destination:=Range("G6:G8"), Type:=xlFillDefault
    Range("H6").AutoFill Destination:=Range("H6:H8"), Type:=xlFillDefault
    ' Copy paste value
    Range("G6:H8").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ' supprime colonne Z
    Columns("Z:Z").Delete Shift:=xlToLeft
    [A1].Select
End Sub
 

Pièces jointes

  • test (25)V3.xlsm
    33.6 KB · Affichages: 5
Dernière édition:
Vote positif 0 Vote négatif
V

viken76

XLDnaute Nouveau
sylvanu à dit:
Re,
Si le nombre de lignes est élevé la macro précédente est lente.
En PJ un nouvel algo qui prend 66ms pour 1000 lignes avec :
VB: 
Sub Compte()
    Dim DL%
    Application.ScreenUpdating = False
    ' Taille de la liste
    DL = Cells(Rows.Count, "A").End(xlUp).Row
    ' Insére une colonne en Z
    Columns("Y:Y").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ' Copie formule en Z3
    Cells(3, "Z").FormulaR1C1 = _
    "=IF(COUNTIF(R1C2:RC[-24],RC[-24])=1,SUMIF(C[-24],RC[-24],C[-23])+(ROW()/10000),0)"
    ' La duplique sur toute la colonne
    Range(Cells(3, "Z"), Cells(DL, "Z")).FillDown
    ' Colle les valeurs
    Range(Cells(3, "Z"), Cells(DL, "Z")).Value = Range(Cells(3, "Z"), Cells(DL, "Z")).Value
    ' Met formule Qté
    Range("H6").Select
    ActiveCell.FormulaR1C1 = "=INT(LARGE(C[18],RC[-2]))"
    ' Met formule nom produit
    Range("G6").Select
    ActiveCell.FormulaR1C1 = "=INDEX(C[-5],MATCH(LARGE(C[19],RC[-1]),C[19],0))"
    ' Duplique formules
    Range("G6").AutoFill Destination:=Range("G6:G8"), Type:=xlFillDefault
    Range("H6").AutoFill Destination:=Range("H6:H8"), Type:=xlFillDefault
    ' Copy paste value
    Range("G6:H8").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ' supprime colonne Z
    Columns("Z:Z").Delete Shift:=xlToLeft
    [A1].Select
End Sub
Cliquez pour agrandir...


Merci, je suis impressionné par la qualité de la réponse à mon problème :)
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir à tous :),

Une autre version avec moins d'instruction et également rapide. Cliquer sur le bouton "Hop!"
Pour 50.000 lignes source (avec 20 produits), le temps d'exécution est d'environ 0,6 secondes (sur ma bécane bien sûr).
le code est dans le module de la feuille "Feuil1" :
VB: 
Sub palmares()
Dim n&, adresse
   Application.ScreenUpdating = False: If Me.FilterMode Then Me.ShowAllData
   Range("g6:h" & Me.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
   n = Cells(Rows.Count, "c").End(xlUp).Row - 2
   adresse = Range("b3:c3").Resize(n).Address(True, True, xlR1C1, True)
   Range("g6").Consolidate Sources:=adresse, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
   n = Cells(Rows.Count, "g").End(xlUp).Row
   Range("g5:h" & n).Sort key1:=Range("h5"), order1:=xlDescending, Header:=xlYes
   Range("g9:h" & Me.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
End Sub
 

Pièces jointes

  • viken76- palmares- v1.xlsm
    17.8 KB · Affichages: 8
Dernière édition:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,

La méthode" Consolider" employée dans la v1 ne convient pas si le nombre de ligne à consolider est très grand (exemple : avec 100.000 lignes, "Consolider" échoue).

Voici la v2 qui fonctionne même avec un grand nombre de ligne. Pour 100.000 lignes source (avec 20 produits), le temps d'exécution est compris entre 3,6 et 3,7 secondes (sur ma bécane bien sûr). C'est moins rapide que la v1.

Code dans le module de la feuille "Feuil1":
VB: 
Sub palmares()
Dim n&, formule
   Application.ScreenUpdating = False: If Me.FilterMode Then Me.ShowAllData
   Range("g6:h" & Me.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
   n = Cells(Rows.Count, "c").End(xlUp).Row - 2
   Range("g6").Resize(n) = Range("b3").Resize(n).Value
   Range("g6").Resize(n).RemoveDuplicates Array(1), Header:=xlNo
   formule = "=SUMIF(plagecrit,crit,plagesomm)"
   formule = Replace(formule, "plagecrit", Range("b3").Resize(n).Address)
   formule = Replace(formule, "crit", Range("g6").Address(0, 0))
   formule = Replace(formule, "plagesomm", Range("c3").Resize(n).Address)
   n = Cells(Rows.Count, "g").End(xlUp).Row - 5
   Range("h6").Resize(n).Formula = formule
   Range("h6").Resize(n) = Range("h6").Resize(n).Value
   Range("g5").Resize(n + 1, 2).Sort key1:=Range("h5"), order1:=xlDescending, Header:=xlYes
   Range("g9:h" & Me.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
End Sub
 

Pièces jointes

  • viken76- palmares- v2.xlsm
    18.9 KB · Affichages: 5
Dernière édition:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re à tous,

Une méthode qui utilise la méthode rapide "Consolider" (comme la v1) et qui cependant fonctionne pour un grand nombre de ligne.

Elle reste rapide : sur ma bécane, le temps d'exécution varie de 1,10 s à 1,15 s pour 120.000 lignes sources.

De la v1, v2, v1.1, c'est cette dernière qui est la plus rapide. Voir le fichier ci-joint.
  • Cliquer sur le bouton Init pour créer les 120.000 lignes de données sources.
  • Cliquer sur le bouton Hop! pour calculer le palmarès.

Le code :
VB: 
Sub palmares()
Const Pas = 10000
Dim n&, adresse, i1&, i2&, deb, m, col&
   deb = Timer: Application.ScreenUpdating = False
   If Me.FilterMode Then Me.ShowAllData
   Range("g6:h" & Me.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
   n = Cells(Rows.Count, "c").End(xlUp).Row
   adresse = Range("b3:c" & n).Address(True, True, xlR1C1, True)
   i1 = 3: i2 = i1 + Pas - 1
   If i2 > Rows.Count Then i2 = Rows.Count
   If i2 > n Then i2 = n
   col = Me.Cells.SpecialCells(xlCellTypeLastCell).Column + 2
   col = Columns.Count - 1: Columns(col).Resize(, 2).Delete
   Do
      With Cells(Rows.Count, col).End(xlUp).Offset(1)
         adresse = Range("b" & i1 & ":c" & i2).Address(True, True, xlR1C1, True)
         .Consolidate Sources:=adresse, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
         i1 = i2 + 1: If i1 > n Then Exit Do
         i2 = i1 + Pas - 1
         If i2 > Rows.Count Then i2 = Rows.Count
         If i2 > n Then i2 = n
      End With
   Loop
   adresse = Cells(2, col).CurrentRegion.Address(True, True, xlR1C1, True)
   Range("g6").Consolidate Sources:=adresse, Function:=xlSum, TopRow:=False, LeftColumn:=True, CreateLinks:=False
   n = Cells(Rows.Count, "g").End(xlUp).Row
   Range("g5:h" & n).Sort key1:=Range("h5"), order1:=xlDescending, Header:=xlYes
   Range("g9:h" & Me.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
   Columns(col).Resize(, 2).Delete
   MsgBox Format(Timer - deb, "0.00\ sec."), vbInformation
End Sub
 

Pièces jointes

  • viken76- palmares- v1.1.xlsm
    20.5 KB · Affichages: 11
Dernière édition:
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Viken, Mapomme, Eriiic,
Ceci étant dit, si la liste des produits est faible, autour de 1000 ou 2000 , la solution la plus simple et la plus rapide est sans VBA.
Tout dépend de l'application finale.
En PJ un essai avec 2000 lignes.
 

Pièces jointes

  • test (25)V5.xlsx
    126.9 KB · Affichages: 3
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL 2021 calcul : Somme des quantités de chaque produit à fabriquer
Réponses
3
Affichages
467
MinstrelL
M
M
  • Question
XL pour MAC outil de gestion du temps de travail
Réponses
1
Affichages
610
gbinforme
G
D
  • Question
Autres novice, excel 2007
Réponses
4
Affichages
660
dany67
D
G
  • Question
XL 2016 Fichier de suivi contrat intérim
Réponses
3
Affichages
2 K
Robert
Robert
L
  • Question
XL 2013 index pour report de données via liste déroulante
2
Réponses
21
Affichages
3 K
Dugenou
Dugenou
E
  • Résolu(e)
XL 2013 macro copie données de l'onglet d'un classeur vers l'onglet d'un autre classeur
Réponses
1
Affichages
2 K
EricCo
E
J
  • Question
Microsoft 365 Recherche de nombre d'évènements sur une durée donnée
Réponses
8
Affichages
1 K
julien6337
J
A
  • Résolu(e)
Calcul somme.si.ens avec critère de date pour chaque nouvelle valeur unique.
Réponses
6
Affichages
2 K
alejandro
A
J
  • Question
Base de données pour traitement avec Tableau Croisé Dynamique
Réponses
9
Affichages
1 K
chris
chris
D
  • Question
Recuperation/Transformation Body de mails Outlook
Réponses
9
Affichages
1 K
Dannan
D

Membres actuellement en ligne

17 membres et 121 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 211
Messages
2 086 291
Membres
103 171
dernier inscrit
clemm