Pareto VBA
Bonjour,
Je dois faire un pareto sur Excel avec VBA mettant en avant la quantité de produits refusés. Cependant, mon code ne fonctionne pas. Le pareto apparaît mais ce dernier est vide, je ne comprends pas pourquoi.
Bonjour Sass bonjour le forum,
La procédure Creation_graph_Pareto_mat_premiere n'existe pas dans ton fichier donc le code :
Private Sub Cb_Pareto_Click()
Call Creation_graph_Pareto_mat_premiere
End Subplante dès la première ligne...
Bonjour,
je n'arrive pas à vous envoyer le fichier avec la macro même compresser ( on me dit qu'il est trop volumineux)
Voici le code que j'ai crée sur un module ( qui je l'avoue à l'air compliqué mais je n'ai pas trouvé plus simple) :
Sub Creation_graph_Pareto_mat_premiere()
' Construire le graphique quelque soit le nombre de données
Application.ScreenUpdating = False
'version 1 sans prise en compte date début et fin par l'utilisateur
'Declaration des variables
'declaration de variables inconnues
Dim Int_Col_Abcisse As Integer
'declaration compteurs
Dim Int_Compteur_x As Integer ' variable de compteur pour boucles utilitaires en x
Dim Si_Compteur_y As Single ' variable de compteur pour boucles utilitaires en x
Dim Si_Compteur_Non_Conformites_totales As Single
Dim Int_Compteur_Empty_x As Integer 'nombre de cellules vides dans une ligne
Dim Si_Compteur_Fournisseur_Tampon As Single 'compteur pour scan vertical fournisseurs dans feuille tampon
Dim Si_Compteur_y_Code_Mat As Single
'declaration variables tableaux
Dim Si_Xtab_Donnees As Single 'x tableau de donnees
Dim Si_Ytab_Donnees As Single 'y tableau de donnees
'declaration element graphe
Dim St_Nom_Graphe As String
Dim St_Nom_Feuille_Graphe As String
Dim St_Abscisse As String
Dim St_donnees_source_graphe As String
Dim Int_L_Fin As Integer
Dim Int_L_Debut As Integer
Dim Si_L_Fin_Mat_Premiere As Single
Dim Int_Total_NC As Integer
Dim St_Nom_Abcisse_graphe As String
Dim St_Nom_Ordonnees_graphe As String
Dim St_Nom_Feuille_Code_Mat As String
Dim int_derniere_ligne As Double
'declaration donnees generales
Dim St_Nom_Classeur As String
Dim St_Nom_Feuille_Donnees As String
'declaration variables pour traitement
Dim Boo_Sortie As Boolean
Dim Boo_Fournisseur_trouve As Boolean
'declaration des constantes
Const St_Nom_Feuille_Tampon As String = "Tampon_Pareto"
Const Si_Lim_Fin_Boucle_y As Single = 1048576 ' 1048576on utilise des boucles for avec une limite elevee pour eviter les boucles while. La limite est arbitraire et correspond au nombre de lignes maximum d'une feuille excel
Const Int_Lim_Fin_Boucle_x As Integer = 7 'lim correspondant au nombre de colonnes utlises a chaque ligne dans le tableau
Const Int_Num_Col_Refusee As Integer = 7 'la caracteristique refusee est a la 7 eme colonne actuellement
Const Int_Num_Col_Matiere_Premiere As Integer = 2 'la caracteristique refusee est a la 7 eme colonne actuellement
'declaration tableaux de traitement
Dim Tab_Recuperation_Des_Donnees() As Variant 'utilisation de tableaux virtuels pour un temps de traitement environ 20 fois plus rapide qu une methode conventionnelle
Dim Tab_Synthese_Des_Donnees() As Variant
'recherche de la derniere ligne non vide
int_derniere_ligne = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
'initialisation des variables
St_Nom_Graphe = "Quantité refusée par Matières Premières"
St_Nom_Feuille_Graphe = "Graphique de pareto"
St_Nom_Classeur = ActiveWorkbook.Name 'recupération nom classeur
St_Nom_Feuille_Donnees = Workbooks(St_Nom_Classeur).ActiveSheet.Name 'recuperation nom feuille (feuille sur laquelle est mis le bouton de lancement de la macro)
'variable tampon pour traitement
Boo_Sortie = False
Boo_Fournisseur_trouve = False
'initialisation total de nc
Int_Total_NC = 0
'attribution nom feuille mat premiere
St_Nom_Feuille_Code_Mat = "Mat°1°"
'initialisation fin ligne mat premiere
For Si_Compteur_y = 2 To Si_Lim_Fin_Boucle_y
If IsEmpty(Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Code_Mat).Cells(Si_Compteur_y, 1).Value) Then
Si_L_Fin_Mat_Premiere = Si_Compteur_y
Exit For
End If
Next Si_Compteur_y
'remise a zero feuille tampon
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Activate
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Range(Cells(2, 1), Cells(Si_Lim_Fin_Boucle_y, 8)).ClearContents
'initialisation variables creation graphe
Int_L_Debut = 2 'debut des variables a placer dans le graphique
Int_Col_Abcisse = 5 'colonne correspondant aux categories
'Recuperation donnees de synthese dans le tableau de synthese
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Activate
Tab_Synthese_Des_Donnees = Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Range(Cells(1, 1), Cells(int_derniere_ligne, 3)).Value
'recuperation donnees a traiter dans tableau de traitement
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Donnees).Activate
Tab_Recuperation_Des_Donnees = Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Donnees).Range(Cells(1, 1), Cells(int_derniere_ligne, Int_Lim_Fin_Boucle_x)).Value
'attribution des noms des axes
St_Nom_Abcisse_graphe = Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Code_Mat).Cells(1, 2).Value
St_Nom_Ordonnees_graphe = "Quantité refusée"
'Synthese des donnees pour le pareto
'boucle de scan vertical
For Si_Compteur_y = 2 To int_derniere_ligne
'verification si scan arrivee a la fin des donnees
Int_Compteur_Empty_x = 0 ' reinitialisation compteur de cellules vides
' boucle de scan horizontal
For Int_Compteur_x = 1 To Int_Lim_Fin_Boucle_x
If Tab_Recuperation_Des_Donnees(Si_Compteur_y, Int_Compteur_x) = "" Then 'si aucun element detecte
Int_Compteur_Empty_x = Int_Compteur_Empty_x + 1 ' incrementation compteur cellule vide
'MsgBox " cellule vide en " & "Y : " & Si_Compteur_y & " X : " & Int_Compteur_x
If Int_Compteur_Empty_x = Int_Lim_Fin_Boucle_x Then ' si toute les cellules de la lignes sont vides
Boo_Sortie = True
Exit For ' on a fini le scan des donnees donc on quitte la boucle de recuperation des donnees
End If
End If
Next Int_Compteur_x
If Int_Compteur_Empty_x <> 0 Then ' action quand detection erreur de remplissage sur une des colonnes
End If
If Boo_Sortie = True Then Exit For ' si on a atteint la fin des lignes utilisees on sort de la boucle
Boo_Fournisseur_trouve = False ' reinitialisation variable tampon fournisseur found
'verification si presence non conformite
If Tab_Recuperation_Des_Donnees(Si_Compteur_y, Int_Num_Col_Refusee) = "VRAI" Then
'verification si code fournisseur deja present dans feuille tampon
For Si_Compteur_Fournisseur_Tampon = 2 To Si_Lim_Fin_Boucle_y 'scan vertical
If Tab_Synthese_Des_Donnees(Si_Compteur_Fournisseur_Tampon, 1) = "" Then Exit For 'si fin des donnees en tampon alors on arrete la recherche
'test si correspondance entre code fournisseur et celui de la base de donnee
If Tab_Recuperation_Des_Donnees(Si_Compteur_y, Int_Num_Col_Matiere_Premiere) = Tab_Synthese_Des_Donnees(Si_Compteur_Fournisseur_Tampon, 1) Then
Tab_Synthese_Des_Donnees(Si_Compteur_Fournisseur_Tampon, 2) = Tab_Synthese_Des_Donnees(Si_Compteur_Fournisseur_Tampon, 2) + Tab_Recuperation_Des_Donnees(Si_Compteur_y, 5) 'incrementation du nb de non conformites
Boo_Fournisseur_trouve = True
Exit For
End If
Next Si_Compteur_Fournisseur_Tampon
If Boo_Fournisseur_trouve = False Then ' si le fournisseur n est pas deja enregistre alors on l enregistre dans une nouvelle categorie
Tab_Synthese_Des_Donnees(Si_Compteur_Fournisseur_Tampon, 1) = Tab_Recuperation_Des_Donnees(Si_Compteur_y, Int_Num_Col_Matiere_Premiere)
Tab_Synthese_Des_Donnees(Si_Compteur_Fournisseur_Tampon, 2) = Tab_Recuperation_Des_Donnees(Si_Compteur_y, 5)
End If
End If
Next Si_Compteur_y
'affichage synthese des donnees dans feuille tampon
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Activate
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Range(Cells(1, 1), Cells(Si_Lim_Fin_Boucle_y, 3)).Value = Tab_Synthese_Des_Donnees
'Creation graphe pareto
'obtention dernière ligne des donnees
For Si_Compteur_y = 2 To Si_Lim_Fin_Boucle_y
If IsEmpty(Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 1)) = True Then Exit For
Next Si_Compteur_y
Int_L_Fin = Si_Compteur_y - 1
'copie des donnees
'on place les nouvelles donnees
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Activate
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Range(Cells(1, 1), Cells(Int_L_Fin, 2)).Copy Destination:=Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Range(Cells(1, 5), Cells(Int_L_Fin, 6))
'remplacement des codes matiere par les nom des matières premières
For Si_Compteur_y = 2 To Int_L_Fin
For Si_Compteur_y_Code_Mat = 2 To Si_L_Fin_Mat_Premiere
If Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 5).Value = Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Code_Mat).Cells(Si_Compteur_y_Code_Mat, 1).Value Then
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 5).Value = Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Code_Mat).Cells(Si_Compteur_y_Code_Mat, 2).Value
End If
Next Si_Compteur_y_Code_Mat
Next Si_Compteur_y
'tri des donnees
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Range(Cells(2, 5), Cells(Int_L_Fin, 6)).Select
ActiveWorkbook.Worksheets(St_Nom_Feuille_Tampon).Range("E1:G" & Int_L_Fin).Sort key1:=Range("F2:F" & Int_L_Fin), Order1:=xlDescending
' ActiveWorkbook.Worksheets(St_Nom_Feuille_Tampon).Sort.SortFields.Add Key:=Range( _
' "F2:F" & Int_L_Fin), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
' xlSortNormal
' With Workbooks(St_Nom_Classeur).Worksheets(St_Nom_Feuille_Tampon).Sort
' .SetRange Range("E1:G" & Int_L_Fin)
' .Header = xlYes
' .MatchCase = False
' .Orientation = xlTopToBottom
' .SortMethod = xlPinYin
' .Apply
' End With
'recuperation total de nc
For Si_Compteur_y = 2 To Int_L_Fin
Int_Total_NC = Int_Total_NC + Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 6).Value
Next Si_Compteur_y
For Si_Compteur_y = 2 To Int_L_Fin
If Si_Compteur_y = 2 Then ' non prise en compte val precedente dans le cas de la premiere valeur
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 7).Value = Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 6).Value / Int_Total_NC
Else
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 7).Value = Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y - 1, 7).Value + Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 6).Value / Int_Total_NC
End If
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Cells(Si_Compteur_y, 7).Style = "Percent"
Next Si_Compteur_y
'utilisation de la feuille St_Nom_Feuille_Tampon
St_Abscisse = "=" & St_Nom_Feuille_Tampon & "!R" & Int_L_Debut & "C" & Int_Col_Abcisse & ":R" & Int_L_Fin & "C" & Int_Col_Abcisse
St_donnees_source_graphe = "F1:G" & Int_L_Fin
'si le graph existe, on le supprime
For Int_Compteur_x = 1 To Sheets.Count
'Sheets(Int_Compteur_x).Activate
If Sheets(Int_Compteur_x).Name = St_Nom_Feuille_Graphe Then
On Error GoTo Continuer
Application.DisplayAlerts = False 'desactivation alerte windows
Sheets(Int_Compteur_x).Delete 'détruit la feuille créée
Application.DisplayAlerts = True
End If
Next Int_Compteur_x
Continuer:
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Activate
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Range(Cells(2, 5), Cells(Int_L_Fin, 7)).Select
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range(St_donnees_source_graphe)
ActiveChart.ChartType = xlColumnClustered
ActiveChart.Location Where:=xlLocationAsNewSheet
ActiveSheet.Name = St_Nom_Feuille_Graphe
Sheets(St_Nom_Feuille_Graphe).Move after:=Sheets(St_Nom_Feuille_Donnees)
ActiveChart.SeriesCollection(1).XValues = "='" & St_Nom_Feuille_Tampon & "'!$E$2:$E$" & Int_L_Fin 'utlisation des abscisses
ActiveChart.SeriesCollection(2).Select[/b
ActiveChart.SeriesCollection(2).AxisGroup = 2
ActiveChart.SeriesCollection(2).Select
ActiveChart.SeriesCollection(2).ChartType = xlLineMarkers
ActiveChart.Axes(xlValue, xlSecondary).Select
ActiveChart.Axes(xlValue, xlSecondary).MaximumScale = 1
ActiveChart.ApplyLayout (5) 'afficher les valeurs sous le graphique
ActiveChart.ChartTitle.Select
ActiveChart.ChartTitle.Text = "Quantité refusée par Matières Premières"
'creation et ajustement position axe ordonnees
ActiveChart.Axes(xlValue).AxisTitle.Select
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = St_Nom_Ordonnees_graphe
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Orientation = xlHorizontal
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Font.Size = 14
Selection.Left = 35
Selection.Top = 15
'creation et ajustement position axe abcisses
ActiveChart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
ActiveChart.Axes(xlCategory).AxisTitle.Select
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Text = St_Nom_Abcisse_graphe
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Font.Size = 14
Selection.Left = 22
Selection.Top = 392
Sheets(St_Nom_Feuille_Graphe).Select
ActiveChart.ChartArea.Select
Application.ScreenUpdating = True
End Sub
Re,
Bon d'abord je dois avouer que je ne sais pas ce qu'est un Pareto. Ensuite, quand je lance ton code j'ai un bug sur cette ligne :
Workbooks(St_Nom_Classeur).Sheets(St_Nom_Feuille_Tampon).ActivateComme il me manque le fichier St_Nom_Classeur, c'est normal. Je pense que tu devrais rajouter l'extension St_Nom_Classeur.xlsx mais il est possible que ça fonctionne ainsi...
Tu disais dans ton premier post que le code fonctionne pas car le Pareto est vide, mais tu n'as pas précisé s'il y avait un message d'erreur et sur quelle ligne ça buguait ou si c'est le code qui ne fait pas le job.
Quoi qu'il en soit, sans avoir toutes les cartes en main je ne peux pas t'aider...
Bonjour à tous,
Pas trop récent, mais il me semble qu'il fonctionne toujours =>
Pierre
Le soucis dans le lien c'est que le tableau a été fait manuellement or je dois tout faire avec VBA
Voici le code que j'ai réussi à faire, mais cela ne fonctionne pas.