décomposition de quantités par paquets

surgeon84fr

surgeon84fr

XLDnaute Junior
Bonjour,

je joints d'office mon fichier car l'explication risque de ne pas etre claire.

Je cherche un moyen simple pour faire une décomposition par paquets de 10 de quantités de matériels.

Je m'explique:

dans ma colonne 1, il y a des codes d'entités.
dans ma colonne 2 , il y a des quantités associées à des types de matériels, qui sont , eux dans la colonne 3.

concretement:
pour l'entité 01E0000, j'ai un total de 14 matériels. Il faut donc décomposer en une ligne de 10 et une ligne de 4, soit 2 lignes pour cette entité.
On passe à l'entité 013E000, j'ai un total de 103 matériels que je dois décomposer en 10 lignes identiques de 10 matériels et une ligne de 3, soit 11 lignes pour cette entité.

etc. pour chaque ligne en fonction du code de l'entité et du total de matériels concernés.

Je vous remercie d'avance pour vos éclairs de génie!!
 

Pièces jointes

  • a decomposer.xlsm
    74.3 KB · Affichages: 38
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : décomposition de quantités par paquets

Re,

Cette longue durée d'exécution m'intriguait.

Je pensais que la mémorisation de chaque ligne du tableau dans la variable a faisait gagner du temps.

Or c'est elle qui plombait la macro :mad:

Avec ce fichier (6) la durée d'exécution passe à 0,78 seconde (Excel 2003) :

Code: 
Sub Décomposé()
Dim t#, derlig&, dercol%, t1, colref%, t2(), i&, n&, j&, k%
t = Timer
With Sheets("A COMPLETER")
  derlig = .Cells(.Rows.Count, 1).End(xlUp).Row
  dercol = .Cells(2, .Columns.Count).End(xlToLeft).Column
  t1 = .[A1].Resize(derlig, dercol)
  colref = Application.Match("QUANTITE", .[2:2], 0)
End With
ReDim t2(1 To Sheets("Décomposé").Rows.Count - 1, 1 To dercol)
For i = 3 To derlig
  n = Int(t1(i, colref) / 10)
  For j = j + 1 To j + n
    For k = 1 To dercol
      t2(j, k) = t1(i, k)
    Next
    t2(j, colref) = 10
  Next
  If t1(i, colref) Mod 10 Then
    For k = 1 To dercol
      t2(j, k) = t1(i, k)
    Next
    t2(j, colref) = t1(i, colref) Mod 10
  Else
    j = j - 1
  End If
Next
With Sheets("Décomposé")
  Sheets("A COMPLETER").Cells.Copy .[A1] 'copie tout
  .[A2].Copy .[A2] 'vide le presse-papiers
  If j Then .[A3].Resize(j, dercol) = t2
  .Activate
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub
A+
 

Pièces jointes

  • A décomposer(6).xls
    615 KB · Affichages: 34
Vote positif 0 Vote négatif
surgeon84fr

surgeon84fr

XLDnaute Junior
Re : décomposition de quantités par paquets

Bonjour job75.

Extraordinaire cette différence de temps!!!!!! Bon le PC du boulot n'a pas l'air aussi performant puisque je tourne en 5s....par rapport à 85s, ça le fait bien quand même:rolleyes:
Voici ma macro complète.
Malgré tes conseils, j'ai laissé mes rajouts puisque le résultat correspond exactement à ce que je voulais :j'ai 2 colonnes de codes , la 1 et la 5, nécessitant la mise en forme "texte"; de plus, une fois la macro executée, ce texte noir ne rendait pas la lisibilité simple, donc j'ai coloré les intérieurs.
:

Sub Décomposer()

Dim t#, derlig&, dercol%, t1, colref%, t2(), i&, n&, j&, k%

t = Timer 'facultatif, pour chronométrer

' supprime l'onglet "Décomposé" s'il existe
Application.DisplayAlerts = False
If SH_exist("Décomposé") = True Then Sheets("Décomposé").Delete
Application.DisplayAlerts = True

' creation de l'onglet "Décomposé"
Sheets.Add after:=Sheets(Worksheets.Count)
Sheets(Worksheets.Count).Name = "Décomposé"

' reproduit le format de l'onglet "A COMPLETER"
Sheets("A COMPLETER").Select
colcredo = Application.Match("CREDO", Sheets("A COMPLETER").[2:2], 0)
Cells.Select
Range("a1").Activate
Selection.Copy
Sheets("Décomposé").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.Zoom = 69
Sheets("A COMPLETER").Select
Rows("1:2").Select
Selection.Copy
Sheets("Décomposé").Select
Rows("1:1").Select
ActiveSheet.Paste
Columns(colcredo).NumberFormat = "@"
Columns(colcredo + 4).NumberFormat = "@"
Sheets("A COMPLETER").Select

With Sheets("A COMPLETER")
derlig = .Cells(.Rows.Count, 1).End(xlUp).Row
dercol = .Cells(2, .Columns.Count).End(xlToLeft).Column
t1 = .[A1].Resize(derlig, dercol)
colref = Application.Match("QUANTITE", .[2:2], 0)
End With

ReDim t2(1 To Sheets("Décomposé").Rows.Count - 1, 1 To dercol)

For i = 3 To derlig
n = Int(t1(i, colref) / 10)
For j = j + 1 To j + n
For k = 1 To dercol
t2(j, k) = t1(i, k)
Next
t2(j, colref) = 10
Next
If t1(i, colref) Mod 10 Then
For k = 1 To dercol
t2(j, k) = t1(i, k)
Next
t2(j, colref) = t1(i, colref) Mod 10
Else
j = j - 1
End If
Next

With Sheets("Décomposé")
If j Then .[A3].Resize(j, dercol) = t2
.[A3].Offset(j).Resize(.Rows.Count - j - 2, dercol).ClearContents
.Activate
End With

'mise en couleur
Application.ScreenUpdating = False

With Sheets("Décomposé")
derlig = .Cells(.Rows.Count, 1).End(xlUp).Row
dercol = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
Range("a3").Select
col = 3

For d = 3 To derlig
Set cel1 = Range("a" & d)
Range(cel1, ActiveCell.Offset(0, dercol - 1)).Interior.ColorIndex = col
Set cel2 = Range("a" & d + 1)
credo1 = cel1.Value
credo2 = cel2.Value
cel2.Select
If credo1 <> credo2 Then
col = col + 1
Range(cel2, ActiveCell.Offset(0, dercol - 1)).Interior.ColorIndex = col
Else
Range(cel2, ActiveCell.Offset(0, dercol - 1)).Interior.ColorIndex = col
End If
If col = 56 Then col = 3
Next d

Application.ScreenUpdating = True

MsgBox "Durée " & Format(Timer - t, "0.0 \s")

End Sub
Cliquez pour agrandir...
Function SH_exist(Nom As String) As Boolean

' test de l'existence d'un onglet

Dim sh As Worksheet

SH_exist = False

For Each sh In Sheets
If sh.Name = Nom Then
SH_exist = True
Exit For
End If
Next

End Function
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : décomposition de quantités par paquets

Bonjour surgeon,

Aïe aïe aïe mes yeux, tous ces Select, Copy, Past :rolleyes:

En VBA il est pratiquement toujours inutile de sélectionner quoi que ce soit.

Et malheureusement l'usine à gaz est le propre des gens peu expérimentés.

Sans rancune et bonne journée.
 
Vote positif 0 Vote négatif
surgeon84fr

surgeon84fr

XLDnaute Junior
Re : décomposition de quantités par paquets

Non sans rancune.

Mais mon inexpérience, ne cache rien à ma volonté d'apprendre!!!! Sinon je ne serais pas venu vous solliciter.

Je sais que VBA est puissant, mais je suis loin de connaitre tous les rouages des automatisations.....

Il se peut que j'ai encore besoin de vos lumières sur mon fichier. Mais en attendant, pourrais-tu juste m'éclairer sur le moyen d'éviter les select et autres copy ou paste?.

Merci d'avance
 
Vote positif 0 Vote négatif
surgeon84fr

surgeon84fr

XLDnaute Junior
Re : décomposition de quantités par paquets

Re

j'ai bien tout regarder au pas par pas. Elle marche nickel cette macro. Vraiment super.

With Sheets("Décomposé")
Sheets("A COMPLETER").Cells.Copy .[A1] 'copie tout
.[A2].Copy .[A2] 'vide le presse-papiers
If j Then .[A3].Resize(j, dercol) = t2
.Activate
End With
Cliquez pour agrandir...

Malgré tes commentaires, je ne comprends pas les .[A1], .[A2] et .[A3]

En te remerciant d'avance.
 
Vote positif 0 Vote négatif
surgeon84fr

surgeon84fr

XLDnaute Junior
Re : décomposition de quantités par paquets

Bonjour job75.

Je vais autant que je peux sur l'aide vba.
En fait, je comprends la forme avec le with et le point.
Ce que je n'ai pas compris, c'est les A1 A2 et A3 entre crochets.
C'est la cellule? Pourquoi A2 vide le presse papier??

Merci pour ta patience.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : décomposition de quantités par paquets

Bonjour surgeon,

.[A1] c'est la même chose que .Range("A1")

Le vidage de la mémoire n'est peut-être pas indispensable ici.

J'ai pris l'habitude de le faire sur Excel 2010 quand je copie une feuille entière car parfois il y a un message d'Excel.

A+
 
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
475
MinstrelL
M
S
  • Question
XL 2016 Problème de classement de prix croissants non désiré
Réponses
4
Affichages
394
chris
chris
N
  • Résolu(e)
XL 2021 Power Query somme des fin de journée où il y a juste une heure de commencement ?
2
Réponses
19
Affichages
924
Cousinhub
Cousinhub
B
  • Résolu(e)
XL 2016 Additionner les quantités et supprimer les lignes en trop
Réponses
9
Affichages
1 K
BPM
B
J
  • Question
XL 2016 Mise en forme conditionnelle en vert de noms, si ces noms figurent dans une liste de noms d'un autre onglet (formules dans MFormCond, ou VBA)
Réponses
5
Affichages
608
sylvanu
sylvanu
Cédric L
  • Question
XL 2019 Récupérer des données et les inscrire jour après jour des premières cellules vides de colonne
2
Réponses
29
Affichages
2 K
Cédric L
Cédric L
B
  • Question
Suppression de colonnes
Réponses
14
Affichages
991
job75
job75
L
  • Résolu(e)
XL 2010 Automatiser par VBA la décomposition d'une ligne d'un fichier en 3 lignes sur un autre onglet
Réponses
7
Affichages
1 K
Lordchris
L
O
  • Résolu(e)
XL 2019 Moyenne de valeurs par date à partir d'un tableau
Réponses
4
Affichages
780
Olocsob
O
F
  • Résolu(e)
Microsoft 365 VBA - Masquer un bloc de ligne - Case a cocher
Réponses
5
Affichages
1 K
Faranor
F

Membres actuellement en ligne

14 membres et 286 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 305
Messages
2 087 090
Membres
103 464
dernier inscrit
Inconnu2