Programmation VBA (boucle do while loop)

Version imprimable

Bonjour, je suis un jeune ingénieur n'ayant jamais travaillé en VBA. Alors pour faciliter mon travail au quotidien, j'aimerai créer un programme qui traite rapidement mes données et m'aide à faire mes analyses rapidement.

Problème:
J'aimerai faire une macro qui dans une période de temps données, ira dans une feuille que j'ai nommé base compter dans une colonne nommée "appréciation" le nombre fois qu'il y a une des appréciations suivante:
- OK
- DUR MAIS NON CASSANT
- OK QUEUE ET FLANC
- MATIERE CASSANTE
- MATIERE MOLE
et viendra dans une autre feuille nommée "essai_VBA" renseigner sur chaque ligne ayant respectivement chacune des appréciation ci-dessus les valeurs trouvées.

En Algo c'est un truc comme ca (j'ai jamais fait)

==> Appuis sur un bouton actualiser
==> Récupère date début
==> Récupère date de fin
==> Va sur la feuille nommée "base" sélectionne la colonne nommée "appréciation"
==> Compte les valeurs de chacune des appréciations
==> Met dans la colonne "occurrence" d'une autre feuille nommée "essai_VBA" sur chaque ligne contenant un des critères d'appréciations ci-dessus les valeurs obtenues.
==> Calcul le pourcentage de chacun des critères

Voici le code que j'ai commencé
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 Sub MAJ_Graph() Dim date_debut As Date Dim date_fin As Date Dim date_debut1 Dim date_fin1 Dim i As Integer Dim cpt_OK As Integer Dim cpt_filet_mous As Integer Dim cpt_matière_cassante As Integer Dim cpt_ok_queue_flanc_milieu_cassant As Integer Dim cpt_filet_bcp_trop_mou As Integer Dim cpt_dur_mais_non_cassant As Integer cpt_OK = 0 cpt_filet_mous = 0 cpt_matière_cassante = 0 cpt_ok_queue_flanc_milieu_cassant = 0 cpt_filet_bcp_trop_mou = 0 cpt_dur_mais_non_cassant = 0 'Demande de la date de début date_debut = Application.InputBox(prompt, "Entrer une date de début", "jj/mm/aaaa") 'Vérification que la date de début est supérieure à la date de début de l'étude Do While date_debut < 41635 date_debut = Application.InputBox(prompt, "Choisir une date supérieure au 27/12/2013 (début d'historique)?", "jj/mm/aaaa") Loop 'Demande de la date de fin date_fin = Application.InputBox(prompt, "Entrer une date de fin", "jj/mm/aaaa") 'Vérification que la date fin est supérieure à la date de début Do While date_fin < date_debut date_fin = Application.InputBox(prompt, "Choisir une date de fin supérieure à la date début", "jj/mm/aaaa") Loop 'Choix de la feuille nommée "base" Sheets("Base").Select 'selectionne toute les lignes et colones de la feuille "Ligne_Prod" Cells.Select 'effectue un tri de date par ordre croissant Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase ':=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal 'Selection et tri par ordre decroissant des dates de la colone E
je sais que je dois faire une boucle do while date_debut <> date_fin mais je ne sais comment mettre la séquence décrite ci-dessus à l'intérieur de la boucle.

Je vous prie de bien vouloir me guider

Merci d'avance pour votre aide

09/08/2014, 13h38
mercatog

Pourquoi passer par vba alors qu'un Tableau croisé dynamique est là pour ça.

Excel contient des outils d'analyse et de synthèse assez flexibles pour ne pas en tenir compte

Bonjour Dbratt, Mercatog, bonjour le forum,

Peut-être comme ça :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Sub MAJ_Graph()
Dim B As Object 'déclare la varoable B (onglet Base)
Dim E As Object 'déclare la varoable E (onglet essai_VBA)
Dim date_debut As Date
Dim date_fin As Date
Dim COL As Integer 'déclare la varoable COL (COLonne)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)
Dim cpt_OK As Integer
Dim cpt_filet_mous As Integer
Dim cpt_matière_cassante As Integer
Dim cpt_ok_queue_flanc_milieu_cassant As Integer
Dim cpt_filet_bcp_trop_mou As Integer
Dim cpt_dur_mais_non_cassant As Integer
 
'cpt_OK = 0
'cpt_filet_mous = 0
'cpt_matière_cassante = 0
'cpt_ok_queue_flanc_milieu_cassant = 0
'cpt_filet_bcp_trop_mou = 0
'cpt_dur_mais_non_cassant = 0
 
Set B = Sheets("Base") 'définit l'onglet B
Set E = Sheets("essai_VBA") 'définit l'onglet E
 
DD: 'étiquette
'Demande de la date de début
date_debut = Application.InputBox(prompt, "Entrer une date de début", "jj/mm/aaaa")
If date_debut = False Then Exit Sub 'si date non renseignée sort de la procédure
If DateSerial(Year(date_debut), Month(date_debut), Day(date_debut)) < 41635 Then 'condition : si la date est inférieure à 27/12/2013
    MsgBox "Choisir une date supérieure au 27/12/2013 (début d'historique)?" 'message
    GoTo DD 'va à l'étiquette DD
End If 'fin de la condition
 
DF: 'étiquette
'Demande de la date de fin
date_fin = Application.InputBox(prompt, "Entrer une date de fin", "jj/mm/aaaa")
If date_fin = False Then Exit Sub 'si date non renseignée sort de la procédure
If CDate(date_fin) < CDate(date_debut) Then 'condition : si la date de fin est inférieure à la date de début
    MsgBox "Choisir une date de fin supérieure à la date début !" 'message
    GoTo DF 'va à l'étiquette DF
End If 'fin de la condition
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
'définit la colonne COL (tu pourras l'écrire en dur puisque tu sais où elle se trouve)
COL = B.Rows(1).Find("appréciation", , xlValues, xlWhole).Column
DL = B.Cells(Application.Rows.Count, COL).End(xlUp).Row 'définit la dernière ligne éditée Dl de la colonne COL de l'onglet "Base"
Set PL = B.Range(B.Cells(2, COL), B.Cells(DL, COL)) 'définit la palge PL contenant les appréciations
'filtre la colonne E (des dates) entre les deux date renseignées, date_debut et date_fin
B.Range("A1").AutoFilter Field:=5, Criteria1:=">=" & Year(date_debut) & "/" & Month(date_debut) & "/" & Day(date_debut), Operator:=xlAnd, _
   Criteria2:="<=" & Year(date_fin) & "/" & Month(date_fin) & "/" & Day(date_fin)
Set PLV = PL.SpecialCells(xlCellTypeVisible) 'de'finit la palge PLV des cellule visibles non filtrées) de la plage PL
cpt_OK = Application.WorksheetFunction.CountIf(PLV, "OK") 'récupère le nombre appréciation
'cpt_filet_mous =application.WorksheetFunction.CountIf(PLV,?") tu as oublié de dire à quoi ça correspondait
cpt_matière_cassante = Application.WorksheetFunction.CountIf(PLV, "MATIERE CASSANTE") 'récupère le nombre appréciation
cpt_ok_queue_flanc_milieu_cassant = Application.WorksheetFunction.CountIf(PLV, "OK QUEUE ET FLANC") 'récupère le nombre appréciation
'attention il y deux "L" à MOLLE !
cpt_filet_bcp_trop_mou = Application.WorksheetFunction.CountIf(PLV, "MATIERE MOLLE") 'récupère le nombre appréciation
cpt_dur_mais_non_cassant = Application.WorksheetFunction.CountIf(PLV, "DUR MAIS NON CASSANT") 'récupère le nombre appréciation
B.Range("A1").AutoFilter 'supprimem le filtre automatique
 
'**************************************************************************************************
'après, à toi de coder pour renvoyer les compteurs dans les bonnes cellules de l'onglet essai_VBA...
'**************************************************************************************************
 
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

09/08/2014, 14h20
Philippe Tulliez

Bonjour,
En plus des outils invoqués par Mercatog avec lequel je suis d'accord à 100%, (pourquoi ne pas faire des macros qui font la somme d'une colonne), il existe des formules peu utilisées et pourtant bien pratiques qu se retrouvent dans la catégories Base de données telles que BDSOMME, BDNB, BDNBVAL, etc.
Ces formules ont toutes la même syntaxe et fonctionnent selon le même principe que les filtres avancés d'excel avec une zone data et une zone des critères.

Bonjour,

Merci à vous pour vos conseils! Je suis bien conscient que les TCD peuvent m'aider mais à un moment donnée ils deviennent insuffisant. Ici j'ai juste commencé par présenter le début de ce que je voudrai faire et je suis très satisfait du résultat.

Thautheme, Merci beaucoup ! comme tu me l'as dit j'ai réussi à afficher les résultats à la bonne position comme tu le verras sur le code ci-dessous. Il n'est pas trop performant mais bon il marche. Si jamais tu peux m'aider à le rendre performant ca m'aidera beaucoup dans mes futurs programmes.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Sub MAJ_Graph()
Dim B As Object 'déclare la varoable B (onglet Base)
Dim E As Object 'déclare la varoable E (onglet essai_VBA)
Dim date_debut As Date
Dim date_fin As Date
Dim COL As Integer 'déclare la varoable COL (COLonne)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)
Dim cpt_OK As Integer
Dim cpt_filet_mous As Integer
Dim cpt_matière_cassante As Integer
Dim cpt_ok_queue_flanc_milieu_cassant As Integer
Dim cpt_filet_bcp_trop_mou As Integer
Dim cpt_dur_mais_non_cassant As Integer
 
Set B = Sheets("Base") 'définit l'onglet B
Set E = Sheets("Essai_VBA") 'définit l'onglet E
 
DD: 'étiquette
'Demande de la date de début
date_debut = Application.InputBox(prompt, "Entrer une date de début", "jj/mm/aaaa")
If date_debut = False Then Exit Sub 'si date non renseignée sort de la procédure
If DateSerial(Year(date_debut), Month(date_debut), Day(date_debut)) < 41635 Then 'condition : si la date est inférieure à 27/12/2013
    MsgBox "Choisir une date supérieure au 27/12/2013 (début d'historique)?" 'message
    GoTo DD 'va à l'étiquette DD
End If 'fin de la condition
 
DF: 'étiquette
'Demande de la date de fin
date_fin = Application.InputBox(prompt, "Entrer une date de fin", "jj/mm/aaaa")
If date_fin = False Then Exit Sub 'si date non renseignée sort de la procédure
If CDate(date_fin) < CDate(date_debut) Then 'condition : si la date de fin est inférieure à la date de début
    MsgBox "Choisir une date de fin supérieure à la date début !" 'message
    GoTo DF 'va à l'étiquette DF
End If 'fin de la condition
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
'définit la colonne COL
COL = B.Rows(1).Find("Appréciations qualité filet (queue, flanc)", , xlValues, xlWhole).Column
DL = B.Cells(Application.Rows.Count, COL).End(xlUp).Row 'définit la dernière ligne éditée Dl de la colonne COL de l'onglet "Base"
Set PL = B.Range(B.Cells(2, COL), B.Cells(DL, COL)) 'définit la palge PL contenant les appréciations
'filtre la colonne E (des dates) entre les deux date renseignées, date_debut et date_fin
B.Range("E1").AutoFilter Field:=5, Criteria1:=">=" & Year(date_debut) & "/" & Month(date_debut) & "/" & Day(date_debut), Operator:=xlAnd, _
   Criteria2:="<=" & Year(date_fin) & "/" & Month(date_fin) & "/" & Day(date_fin)
Set PLV = PL.SpecialCells(xlCellTypeVisible) 'definit la palge PLV des cellule visibles non filtrées) de la plage PL
cpt_OK = Application.WorksheetFunction.CountIf(PLV, "OK") 'récupère le nombre appréciation
cpt_filet_mous = Application.WorksheetFunction.CountIf(PLV, "FILET MOU") 'récupère le nombre d'appréciation
cpt_matière_cassante = Application.WorksheetFunction.CountIf(PLV, "MATIERE CASSANTE") 'récupère le nombre appréciation
cpt_ok_queue_flanc_milieu_cassant = Application.WorksheetFunction.CountIf(PLV, "OK QUEUE & FLANC; MILIEU CASSANT") 'récupère le nombre appréciation
cpt_filet_bcp_trop_mou = Application.WorksheetFunction.CountIf(PLV, "FILETS BEAUCOUP TROP MOUS") 'récupère le nombre appréciation
cpt_dur_mais_non_cassant = Application.WorksheetFunction.CountIf(PLV, "DUR MAIS NON CASSANT") 'récupère le nombre appréciation
B.Range("E1").AutoFilter 'supprimem le filtre automatique
 
Sheets("Essai_VBA").Select 'je selectionne la feuille essai_VBA
Range("B3:C9").Clear 'j'efface les valeurs antérieures
 
'selectionne la première cellule afin de positionner les autres cellule par rapport à elle
Range("A1").Select
ActiveCell.Offset(7, 2) = cpt_dur_mais_non_cassant
ActiveCell.Offset(3, 2) = cpt_filet_bcp_trop_mou
ActiveCell.Offset(6, 2) = cpt_ok_queue_flanc_milieu_cassant
ActiveCell.Offset(4, 2) = cpt_matière_cassante
ActiveCell.Offset(5, 2) = cpt_OK
ActiveCell.Offset(2, 2) = cpt_filet_mous
'calcul de la somme des occurrences
ActiveCell.Offset(8, 2) = Application.WorksheetFunction.Sum(Range("c3:c8"))
'calcul des pourcentage
Range("B3:B9").NumberFormat = "0.00%"
ActiveCell.Offset(7, 1) = Range("C8").Value / Range("C9").Value 'dur mais non cassant
ActiveCell.Offset(3, 1) = Range("C4").Value / Range("C9").Value 'filet bcp trop mou
ActiveCell.Offset(6, 1) = Range("C7").Value / Range("C9").Value 'ok queue flanc milieu cassant
ActiveCell.Offset(4, 1) = Range("C5").Value / Range("C9").Value 'matière cassante
ActiveCell.Offset(5, 1) = Range("C6").Value / Range("C9").Value 'ok
ActiveCell.Offset(2, 1) = Range("C3").Value / Range("C9").Value 'filet mou
 
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
 
End Sub

j'aimerai bien représenter les résultats sur un graphique et je ne sais pas comment faire ! Aussi j'ai quelques questions concernant ce code:

Set B = Sheets("Base") 'définit l'onglet B : Pourquoi le faire?
Set E = Sheets("Essai_VBA") 'définit l'onglet E : Pourquoi le faire?
DF: 'étiquette : Pourquoi le faire?

Je voudrai comprendre à quoi ils servent et pourquoi sont ils important

Merci beaucoup je crois que me m'inspirerai de ce code pour faire d'avantage de comptage et autres opérations sur ma base !

10/08/2014, 17h23
mercatog

Excel

Feuille Essai vba

Si on B1 on a la date début et en C1 la date fin

En C3:

Code:

=SOMMEPROD((Base!$B$2:$B$1000=$A3)*(Base!$E$2:$E$1000>=$B$1)*(Base!$E$2:$E$1000<=$C$1)*1)

(1000 étant le nombre de lignes de la base (on peut le rendre dynamique ou bien utiliser une Tableau)

On tire jusqu'en C8

EN B3 une simple

Code:

=C3/$C$9

On tire jusqu'en B8

En C9 une simple

Code:

=SOMME($C$3:$C$8)

On trace notre graphique comme on veut

Lorsqu'on change les dates en B1 et C1, tout se met à jour

Bonsoir le fil, bonsoir le forum,

Citation:

Aussi j'ai quelques questions concernant ce code:
Set B = Sheets("Base") 'définit l'onglet B : Pourquoi le faire?
Set E = Sheets("Essai_VBA") 'définit l'onglet E : Pourquoi le faire?
DF: 'étiquette : Pourquoi le faire?
Je voudrai comprendre à quoi ils servent et pourquoi sont ils important
Merci beaucoup je crois que me m'inspirerai de ce code pour faire d'avantage de comptage et autres opérations sur ma base !

C'est juste pour m'éviter d'écrire Sheets("Base") chaque fois, j'écris B à la place. Ou Sheets("essai_VBA") que j'écris E.
Pour illustrer cela, ton code modifié :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Sub MAJ_Graph()<br>
Dim B As Object 'déclare la variable B (onglet Base)<br>
Dim E As Object 'déclare la variable E (onglet essai_VBA)<br>
Dim date_debut As Date<br>
Dim date_fin As Date<br>
Dim COL As Integer 'déclare la variable COL (COLonne)<br>
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)<br>
Dim PL As Range 'déclare la variable PL (PLage)<br>
Dim PLV As Range 'déclare la variable PLV (PLage Visible)<br>
Dim cpt_OK As Integer<br>
Dim cpt_filet_mous As Integer<br>
Dim cpt_matière_cassante As Integer<br>
Dim cpt_ok_queue_flanc_milieu_cassant As Integer<br>
Dim cpt_filet_bcp_trop_mou As Integer<br>
Dim cpt_dur_mais_non_cassant As Integer<br>
&nbsp;<br>
Set B = Sheets("Base") 'définit l'onglet B<br>
Set E = Sheets("Essai_VBA") 'définit l'onglet E<br>
&nbsp;<br>
DD: 'étiquette<br>
'Demande de la date de début<br>
date_debut = Application.InputBox(prompt, "Entrer une date de début", "jj/mm/aaaa")<br>
If date_debut = False Then Exit Sub 'si date non renseignée sort de la procédure<br>
If DateSerial(Year(date_debut), Month(date_debut), Day(date_debut)) &lt; 41635 Then 'condition : si la date est inférieure à 27/12/2013<br>
&nbsp;&nbsp; &nbsp;MsgBox "Choisir une date supérieure au 27/12/2013 (début d'historique)?" 'message<br>
&nbsp;&nbsp; &nbsp;GoTo DD 'va à l'étiquette DD<br>
End If 'fin de la condition<br>
&nbsp;<br>
DF: 'étiquette<br>
'Demande de la date de fin<br>
date_fin = Application.InputBox(prompt, "Entrer une date de fin", "jj/mm/aaaa")<br>
If date_fin = False Then Exit Sub 'si date non renseignée sort de la procédure<br>
If CDate(date_fin) &lt; CDate(date_debut) Then 'condition : si la date de fin est inférieure à la date de début<br>
&nbsp;&nbsp; &nbsp;MsgBox "Choisir une date de fin supérieure à la date début !" 'message<br>
&nbsp;&nbsp; &nbsp;GoTo DF 'va à l'étiquette DF<br>
End If 'fin de la condition<br>
&nbsp;<br>
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran<br>
'définit la colonne COL<br>
COL = B.Rows(1).Find("Appréciations qualité filet (queue, flanc)", , xlValues, xlWhole).Column<br>
DL = B.Cells(Application.Rows.Count, COL).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne COL de l'onglet "Base"<br>
Set PL = B.Range(B.Cells(2, COL), B.Cells(DL, COL)) 'définit la palge PL contenant les appréciations<br>
'filtre la colonne E (des dates) entre les deux date renseignées, date_debut et date_fin<br>
B.Range("E1").AutoFilter Field:=5, Criteria1:="&gt;=" &amp; Year(date_debut) &amp; "/" &amp; Month(date_debut) &amp; "/" &amp; Day(date_debut), Operator:=xlAnd, _<br>
&nbsp;&nbsp; Criteria2:="&lt;=" &amp; Year(date_fin) &amp; "/" &amp; Month(date_fin) &amp; "/" &amp; Day(date_fin)<br>
Set PLV = PL.SpecialCells(xlCellTypeVisible) 'definit la palge PLV des cellule visibles (non filtrées) de la plage PL<br>
cpt_OK = Application.WorksheetFunction.CountIf(PLV, "OK") 'récupère le nombre appréciation<br>
cpt_filet_mous = Application.WorksheetFunction.CountIf(PLV, "FILET MOU") 'récupère le nombre d'appréciation<br>
cpt_matière_cassante = Application.WorksheetFunction.CountIf(PLV, "MATIERE CASSANTE") 'récupère le nombre appréciation<br>
cpt_ok_queue_flanc_milieu_cassant = Application.WorksheetFunction.CountIf(PLV, "OK QUEUE &amp; FLANC; MILIEU CASSANT") 'récupère le nombre appréciation<br>
cpt_filet_bcp_trop_mou = Application.WorksheetFunction.CountIf(PLV, "FILETS BEAUCOUP TROP MOUS") 'récupère le nombre appréciation<br>
cpt_dur_mais_non_cassant = Application.WorksheetFunction.CountIf(PLV, "DUR MAIS NON CASSANT") 'récupère le nombre appréciation<br>
B.Range("E1").AutoFilter 'supprime le filtre automatique<br>
<br>
E.Range("B3:C9").Clear 'j'efface les valeurs antérieures<br>
'selectionne la première cellule afin de positionner les autres cellule par rapport à elle<br>
E.Range("A1").Offset(7, 2) = cpt_dur_mais_non_cassant<br>
E.Range("A1").Offset(3, 2) = cpt_filet_bcp_trop_mou<br>
E.Range("A1").Offset(6, 2) = cpt_ok_queue_flanc_milieu_cassant<br>
E.Range("A1").Offset(4, 2) = cpt_matière_cassante<br>
E.Range("A1").Offset(5, 2) = cpt_OK<br>
E.Range("A1").Offset(2, 2) = cpt_filet_mous<br>
'calcul de la somme des occurrences<br>
E.Range("A1").Offset(8, 2) = Application.WorksheetFunction.Sum(Range("c3:c8"))<br>
'calcul des pourcentage<br>
E.Range("B3:B9").NumberFormat = "0.00%"<br>
E.Range("A1").Offset(7, 1) = E.Range("C8").Value / E.Range("C9").Value 'dur mais non cassant<br>
E.Range("A1").Offset(3, 1) = E.Range("C4").Value / E.Range("C9").Value 'filet bcp trop mou<br>
E.Range("A1").Offset(6, 1) = E.Range("C7").Value / E.Range("C9").Value 'ok queue flanc milieu cassant<br>
E.Range("A1").Offset(4, 1) = E.Range("C5").Value / E.Range("C9").Value 'matière cassante<br>
E.Range("A1").Offset(5, 1) = E.Range("C6").Value / E.Range("C9").Value 'ok<br>
E.Range("A1").Offset(2, 1) = E.Range("C3").Value / E.Range("C9").Value 'filet mou<br>
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran<br>
End Sub

Évite autant que tu le peux les Select inutiles. Il ne font que ralentir l'exécution du code

Code:

1
2
3
Sheets("essai_VBA").Select
Range("A1").Select
ActiveCell.Offset(7, 2) = cpt_dur_mais_non_cassant

Peux s'écrire tout simplement :

Code:

E.Range("A1").Offset(7, 2) = cpt_dur_mais_non_cassant

Les étiquette DD (Date de Début) et DF (Date de fin) remplacent ton Loop. Si la boîte d'entrée de la date de début n'est pas valide le code renvoie à l'étiquette DD qui se trouve juste avant l'ouverture de cette boîte d'entrée. Donc, à la validation [OK] de la boîte d'entrée de la date de début, si la donnée éditée n'est pas valide, ça ouvre à nouveau cette même boîte d'entrée. Idem pour la date de fin...

Bonsoir,

Je vous remercie du temps que vous consacrez à m'aider. Merci pour vos éclaircissements...

Sur ce programme, j'ai rajouté le code ci-dessous et il bloque sur la première ligne de ce code. j'ai l'erreur "424 object required" ! Je ne sais pas si la syntaxe est bonne

Code:

1
2
3
cpt_ok_R = Application.WorksheetFunction.CountIfs(PVL, "OK" & PVL_OK_R, 0)
cpt_ok_UP = Application.WorksheetFunction.CountIfs(PVL, "OK" & PVL_OK_UP, "<0")
cpt_ok_DOWN = Application.WorksheetFunction.CountIfs(PVL, "OK" & PVL_OK_DOWN, ">0")

Voici tout le programme entier:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
Sub MAJ_Graph()
Dim B As Object 'déclare la variable B (onglet Base)
Dim E As Object 'déclare la variable E (onglet essai_VBA)
Dim date_debut As Date
Dim date_fin As Date
Dim COL As Integer 'déclare la variable COL (COLonne)
Dim COL_OK_R As Integer 'déclare la variable colonne pour consigne respectée
Dim COL_OK_UP As Integer 'déclare la variable colonne pour consigne modifiée Sup
Dim COL_OK_DOWN As Integer 'déclare la variable colonne pour consigne modifiée Inf
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim DL_OK_R As Integer 'déclare la variable DL (Dernière Ligne) consigne respectée
Dim DL_OK_UP As Integer 'déclare la variable DL (Dernière Ligne) consigne modifiée Sup
Dim DL_OK_DOWN As Integer 'déclare la variable DL (Dernière Ligne) consigne modifiée Inf
Dim PL As Range 'déclare la variable PL (PLage)
Dim PL_OK_R As Range 'déclare la variable PL (PLage)
Dim PL_OK_UP As Range 'déclare la variable PL (PLage)
Dim PL_OK_DOWN As Range 'déclare la variable PL (PLage)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)
Dim PLV_OK_R As Range 'déclare la variable PLV (PLage Visible)
Dim PLV_OK_UP As Range 'déclare la variable PLV (PLage Visible)
Dim PLV_OK_DOWN As Range 'déclare la variable PLV (PLage Visible)
Dim cpt_OK As Integer
Dim cpt_filet_mous As Integer
Dim cpt_matière_cassante As Integer
Dim cpt_ok_queue_flanc_milieu_cassant As Integer
Dim cpt_filet_bcp_trop_mou As Integer
Dim cpt_dur_mais_non_cassant As Integer
Dim cpt_MilieuOk_QueueMolle As Integer
Dim cpt_ok_R As Integer 'compteur consigne respectée
Dim cpt_ok_UP As Integer 'compteur consigne modifiée Sup
Dim cpt_ok_DOWN As Integer 'compteur consigne modifiée Inf
 
 
Set B = Sheets("Base") 'définit l'onglet B
Set E = Sheets("Essai_VBA") 'définit l'onglet E
 
DD: 'étiquette
'Demande de la date de début
date_debut = Application.InputBox(prompt, "Entrer une date de début", "jj/mm/aaaa")
If date_debut = False Then Exit Sub 'si date non renseignée sort de la procédure
If DateSerial(Year(date_debut), Month(date_debut), Day(date_debut)) < 41635 Then 'condition : si la date est inférieure à 27/12/2013
    MsgBox "Choisir une date supérieure au 27/12/2013 (début d'historique)?" 'message
    GoTo DD 'va à l'étiquette DD
End If 'fin de la condition
 
DF: 'étiquette: Les étiquette DD (Date de Début) et DF (Date de fin) remplacent ton Loop.
    'Si la boîte d'entrée de la date de début n'est pas valide le code renvoie à l'étiquette
    'DD qui se trouve juste avant l'ouverture de cette boîte d'entrée. Donc, à la validation
    '[OK] de la boîte d'entrée de la date de début, si la donnée éditée n'est pas valide, ça
    'ouvre à nouveau cette même boîte d'entrée. Idem pour la date de fin..
 
'Demande de la date de fin
date_fin = Application.InputBox(prompt, "Entrer une date de fin", "jj/mm/aaaa")
If date_fin = False Then Exit Sub 'si date non renseignée sort de la procédure
If CDate(date_fin) < CDate(date_debut) Then 'condition : si la date de fin est inférieure à la date de début
    MsgBox "Choisir une date de fin supérieure à la date début !" 'message
    GoTo DF 'va à l'étiquette DF
End If 'fin de la condition
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
 
'définit la colonne COL
COL = B.Rows(1).Find("Appréciations qualité filet (queue, flanc)", , xlValues, xlWhole).Column
COL_OK_R = B.Rows(1).Find("OK (Consigne respectées)", , xlValues, xlWhole).Column
COL_OK_UP = B.Rows(1).Find("OK( Consigne modifiée Sup)", , xlValues, xlWhole).Column
COL_OK_DOWN = B.Rows(1).Find("OK( Consigne modifiée Inf)", , xlValues, xlWhole).Column
 
'définit la dernière ligne éditée Dl de la colonne COL de l'onglet "Base"
DL = B.Cells(Application.Rows.Count, COL).End(xlUp).Row
DL_OK_R = B.Cells(Application.Rows.Count, COL_OK_R).End(xlUp).Row
DL_OK_UP = B.Cells(Application.Rows.Count, COL_OK_UP).End(xlUp).Row
DL_OK_DOWN = B.Cells(Application.Rows.Count, COL_OK_DOWN).End(xlUp).Row
 
'définit la palge PL contenant les appréciations
Set PL = B.Range(B.Cells(2, COL), B.Cells(DL, COL))
Set PL_OK_R = B.Range(B.Cells(2, COL_OK_R), B.Cells(DL_OK_R, COL_OK_R))
Set PL_OK_UP = B.Range(B.Cells(2, COL_OK_UP), B.Cells(DL_OK_UP, COL_OK_UP))
Set PL_OK_DOWN = B.Range(B.Cells(2, COL_OK_DOWN), B.Cells(DL_OK_DOWN, COL_OK_DOWN))
 
'filtre la colonne E (des dates) entre les deux date renseignées, date_debut et date_fin
B.Range("E1").AutoFilter Field:=5, Criteria1:=">=" & Year(date_debut) & "/" & Month(date_debut) & "/" & Day(date_debut), Operator:=xlAnd, _
   Criteria2:="<=" & Year(date_fin) & "/" & Month(date_fin) & "/" & Day(date_fin)
 
'definit la plage PLV des cellules visibles non filtrées de la plage PL
Set PLV = PL.SpecialCells(xlCellTypeVisible)
Set PLV_OK_R = PL_OK_R.SpecialCells(xlCellTypeVisible)
Set PLV_OK_UP = PL_OK_UP.SpecialCells(xlCellTypeVisible)
Set PLV_OK_DOWN = PL_OK_DOWN.SpecialCells(xlCellTypeVisible)
 
'récupère le nombre appréciation
cpt_OK = Application.WorksheetFunction.CountIf(PLV, "OK")
cpt_filet_mous = Application.WorksheetFunction.CountIf(PLV, "FILET MOU")
cpt_matière_cassante = Application.WorksheetFunction.CountIf(PLV, "MATIERE CASSANTE")
cpt_ok_queue_flanc_milieu_cassant = Application.WorksheetFunction.CountIf(PLV, "OK QUEUE & FLANC; MILIEU CASSANT")
cpt_filet_bcp_trop_mou = Application.WorksheetFunction.CountIf(PLV, "FILETS BEAUCOUP TROP MOUS")
cpt_dur_mais_non_cassant = Application.WorksheetFunction.CountIf(PLV, "DUR MAIS NON CASSANT")
cpt_MilieuOk_QueueMolle = Application.WorksheetFunction.CountIf(PLV, "MILIEU OK; QUEUE MOLLE")
 
'récupère les modifications
cpt_ok_R = Application.WorksheetFunction.CountIfs(PVL, "OK" & PVL_OK_R, 0)
cpt_ok_UP = Application.WorksheetFunction.CountIfs(PVL, "OK" & PVL_OK_UP, "<0")
cpt_ok_DOWN = Application.WorksheetFunction.CountIfs(PVL, "OK" & PVL_OK_DOWN, ">0")
 
 
B.Range("E1").AutoFilter 'supprimer le filtre automatique
 
Sheets("Essai_VBA").Select 'je selectionne la feuille essai_VBA
Range("B5:C12").Clear 'j'efface les valeurs antérieures du tableau appréciations occurrences
Range("B16:C30").Clear 'j'efface les valeurs antérieures du tableau modicications
 
'Mise en forme tableau appréciation et occurrences
Range("A4:C12").Borders.Weight = 2 'mise de la grille
Range("A4:C4").Interior.ColorIndex = 15 'mise en forme
Range("A12:C12").Interior.ColorIndex = 15 'mise en forme
 
'Mise en forme tableau modifications
Range("A16:C30").Borders.Weight = 2 'mise de la grille
Range("A20:C20").Interior.ColorIndex = 15 'mise en forme
Range("A25:C25").Interior.ColorIndex = 15 'mise en forme
Range("A30:C30").Interior.ColorIndex = 15 'mise en forme
 
'selectionne la première cellule afin de positionner les autres cellule par rapport à elle
'E.Range("A1") peut remplacer range("A1").select
E.Range("A1").Offset(5, 2) = cpt_OK
E.Range("A1").Offset(9, 2) = cpt_dur_mais_non_cassant
E.Range("A1").Offset(5, 2) = cpt_filet_bcp_trop_mou
E.Range("A1").Offset(8, 2) = cpt_ok_queue_flanc_milieu_cassant
E.Range("A1").Offset(6, 2) = cpt_matière_cassante
E.Range("A1").Offset(7, 2) = cpt_OK
E.Range("A1").Offset(4, 2) = cpt_filet_mous
E.Range("A1").Offset(10, 2) = cpt_MilieuOk_QueueMolle
 
'calcul de la somme des occurrences tableau appréciations
E.Range("A1").Offset(11, 2) = Application.WorksheetFunction.Sum(Range("c5:c11"))
 
'Positionnement des compteurs dans le tableau modifications
E.Range("A1").Offset(15, 2) = cpt_ok_R
E.Range("A1").Offset(16, 2) = cpt_ok_UP
E.Range("A1").Offset(17, 2) = cpt_ok_DOWN
 
'calcul de la somme des occurrences tableau modifications
E.Range("A1").Offset(19, 2) = Application.WorksheetFunction.Sum(Range("c16:c19"))
 
'calcul des pourcentage
E.Range("B3:B12").NumberFormat = "0.00%"
E.Range("A1").Offset(9, 1) = E.Range("C10").Value / E.Range("C12").Value 'dur mais non cassant
E.Range("A1").Offset(5, 1) = E.Range("C6").Value / E.Range("C12").Value 'filet bcp trop mou
E.Range("A1").Offset(8, 1) = E.Range("C9").Value / E.Range("C12").Value 'ok queue flanc milieu cassant
E.Range("A1").Offset(6, 1) = E.Range("C7").Value / E.Range("C12").Value 'matière cassante
E.Range("A1").Offset(7, 1) = E.Range("C8").Value / E.Range("C12").Value 'ok
E.Range("A1").Offset(4, 1) = E.Range("C5").Value / E.Range("C12").Value 'filet mou
E.Range("A1").Offset(10, 1) = E.Range("C11").Value / E.Range("C12").Value 'Milieu OK; Queue Molle
E.Range("A1").Offset(11, 1) = Application.WorksheetFunction.Sum(Range("B5:B11")) 'calcul pourcentage total
 
'Graph
ThisWorkbook.Activate
ThisWorkbook.Sheets("Essai_VBA").Range("A4:B11").Copy
 
'tracer le graphique
Set Mongraph = ThisWorkbook.Charts.Add
With Mongraph
.SetSourceData Source:=ThisWorkbook.Sheets("Essai_VBA").Range("A4:B11"), PlotBy:=xlColumns
 
'formater le graphique
.ChartType = xlColumnStacked
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Appreciations"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Pourcentage"
.PlotArea.Interior.ColorIndex = 2
.Axes(xlValue).MajorGridlines.Border.LineStyle = xlDot
.ChartArea.Font.Size = 14
.Deselect
 
End With
 
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
 
End Sub

11/08/2014, 23h03
Thautheme

Bonsoir le fil, bonsoir le forum,

Tu proposes d'utiliser Application.WorksheetFunction.CountIfs qui correspond à la fonction NB.Si.Ens que je ne connais absolument pas... Mais du peu que j'en ai vu, il me semble qu'il faut chaque fois associer un critère à une plage de critères. Cela signifie qu'il y aurait, si j'ai bien compris (ce qui est rare...), un nombre pair d'arguments et toi tu en propose trois. C'est peut-être pour cela que ça plante.
Tu as, j'imagine, rajouter ces lignes après avoir définit la plage PLV ? Sinon l'erreur pourrait venir de là.
Ce que je fais dans ces cas, je lance l'enregistreur de macro et j'écris la formule dans une cellule. J'éteins l'enregistreur de macro et je regarde le code qu'il a créé. J'adapte ce code avec les variables pré définies...
Désolé mais je ne vais pas d'être d'un grand secours sur ce coup là...
11/08/2014, 23h44
Dbratt

Merci Thautheme,

Oui j'ai effectivement défini une des plages PLV pour chacun des critères que je souhaite compter. ensuite j'ai juste essayé d'écrire le code comme si j'appliquais la formule NB.SI.ENS (plage1, critère1; plage2, critère2;.....).
J'essaierai de lancer une macro et je verrai bien !

Merci Thautheme
12/08/2014, 01h33
Thautheme

Bonsoir le fil, bonsoir le forum,

Regarde :

Code:

cpt_ok_R = Application.WorksheetFunction.CountIfs(PVL, "OK" & PVL_OK_R, 0)

• premier argument : PLV (une plage, normal)
• deuxième argument : "OK" & PVL_OK_R (un critère, normal)
• troisième argument : 0 (??? ça devrait être une plage, suivie d'un quatrième argument : critère)

Pour moi il y a un argument en trop ou en moins mais dans ce cas 0 nest pas une plage. Je pense que ça plante pour ça...
13/08/2014, 00h16
Dbratt

Bonsoir Thautheme, Bonsoir le forum,

Thautheme,

• premier argument : PLV est la plage et "ok" est le critère à chercher dans la plage PLV
• deuxième argument : PVL_OK_R est la plage et "0" le critère que je recherche dans la cette plage.
En fait j'ai rajouté le "&" juste par ce que quand j'ai mis le ";" le programme refusait de compiler.

en fait j'ai deux plages et deux critères bien précis pour séparer les deux plages j'ai ajouté le "&" car le programme refusait le ";" ! je ne sais pas si la syntaxe est bonne. c'était juste un essai et ça ne marche pas.

je ne sais même pas si on a le droit d'écrire ainsi lorsqu'on fait un comptage avec deux critères !

Merci du temps que vous consacrez à m'éclaircir !
13/08/2014, 00h28
Thautheme

Bonsoir le fil, bonsoir le forum,

Dans ce cas je pense que tu devrais écrire :

Code:

cpt_ok_R = Application.WorksheetFunction.CountIfs(PVL, "OK", PVL_OK_R, 0)

C'est la virgule qui sépare tous les arguments. Mais ce n'est que mon avis je ne te garantis pas le résultat...
13/08/2014, 16h51
Dbratt

Bonsoir Le forum, Bonsoir Thautheme,

J'ai bien essayé la virgule mais ça n'a rien donné donc j'ai du changer de technique ! j'ai re adapté mon fichier "base" pour utiliser countif au lieu de countifs !
donc je compte juste un seul argument!
Actuellement tout fonctionne bien !

Merci bcp à vous et Particulièrement à Thautheme !

Je reviendrai car je compte bien optimise mon fichier ...

Merci William
13/08/2014, 20h35
parmi

Citation:

Dim PLV As Range 'déclare la variable PLV (PLage Visible)

Tu déclares PLV, mais tu utilises PVL dans la formule... ;)
13/08/2014, 23h41
Dbratt

bonne remarque !

Je n'avais pas remarqué cela ! c'est surement pour cela que ça ne marchait pas !

Merci