Optimisation de macro VBA

**Liathe** · 11/03/2020, 10h36

Bonjour à tous,

J'ai réussis après de nombreuses heures à faire la macro qui se trouve en pièce jointe.
Je tiens d'ailleurs à remercier toutes les personnes qui m'ont aidé indirectement en répondant à d'autres personnes!

Mon problème est le suivant, après avoir optimiser mon code pour qu'il agisse plus vite, je trouve que certains userforms sont encore trop lent...
Je demande donc votre aide car j'arrive à la limite de mes connaissances en vba.

Je vous remercie d'avance,
Liathe

EDIT: Les données se trouvant dans le fichier sont des données factices, il n'y a rien de confidentiel. Oui j'ai besoin de traiter 10.000 lignes car la base de données sera très grande, je n'ai mis que quelques lignes pour l'exemple.

**galopin01** · 12/03/2020, 16h58

Bonjour,
On voit que tu as beaucoup travaillé la-dessus, mais ça ne sert à rien de réinventer la roue :
Tu as un problème de conception : A quoi bon faire 6 UserForm pour gérer ta base alors qu'un seul fait la même chose ? Et même plus !
Ce forum est un forum de pro donc si tu escomptes une réponse, il faut utiliser des méthodes "pro" (et lire les recommandations -nombreuses- dans les pages d'accueil du forum) sinon tu vas te faire blacklister rapidement.
En lien une démo de gestion avec un seul UserForm.
Je dis pas que c'est pas perfectible ni même complètement adapté, mébon... c'est juste pour te faire mesurer ton handicap !
A+

**Menhir** · 12/03/2020, 17h58

Envoyé par galopin01

Ce forum est un forum de pro donc si tu escomptes une réponse, il faut utiliser des méthodes "pro" (et lire les recommandations -nombreuses- dans les pages d'accueil du forum) sinon tu vas te faire blacklister rapidement.

Evitons ce type de condescendance. Ce forum est aussi fait pour que des débutants apprennent.

Personnellement, ce qui me retient de répondre, c'est d'avoir balancé un fichier joint dans le premier message, en contradiction avec les règles du forum.
Lire ça : https://www.developpez.net/forums/d8...s-discussions/
Beaucoup de participants n'ouvrent pas les pièces jointes, entre autre pour les raisons expliquées dans ce lien), ce qui limite les occasions d'obtenir une aide.

**Liathe** · 13/03/2020, 09h22

Bonjour galopin01, Menhir

Je vous remercie de m'avoir répondu.

Concernant le message de galopin, comme tu le dis, j'ai beaucoup bossé dessus. Je me suis énormément renseigné car c'est en apprenant seul que j'apprend le mieux. Malheureusement je bloque... J'ai fait 6 userform car je n'ai pas envie de faire un Userform avec un nombre élevé de bouton, le but est que se soit user friendly , pourrais-tu m'expliquer en quoi c'est un problème de conception. Ton lien ne marche pas chez moi, je tombe sur "404 page not found".

Concernant le message de Menhir, j'avoue ne pas avoir lu tous les sujets destiné aux nouvelles personnes et j'en suis désolé. J'ai lu les règles de base et je n'avais pas lu ce que tu m'as envoyé, j'ai donc pallié à ce manquement. Je comprend tout à fait les raisons évoquées dans le sujet, mais je t'avoue que je ne sais pas comment expliquer de manière intelligible la macro puisqu'elle contient 6 userforms qui peuvent s'appeler mutuellement.
Je vais néanmoins mettre le code ci-dessous, et espérer qu'il soit assez clair et pas trop brouillon.

Code Feuil1(BD)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Private Sub CommandButton1_Click()
 
ActiveCell.Select 'enlève le focus au bouton
UserForm1.Show 'affiche L'UserForm1
End Sub
 
Private Sub CommandButton2_Click()
 
ActiveCell.Select 'enlève le focus au bouton
AJOUT.Show 'affiche
 
End Sub
 
Private Sub CommandButton3_Click()
 
ActiveCell.Select 'enlève le focus au bouton
UserForm2.Show 'affiche L'UserForm2
 
End Sub
 
Private Sub CommandButton4_Click()
 
ActiveCell.Select 'enlève le focus au bouton
UserForm3.Show 'affiche L'UserForm3
 
End Sub
 
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
If Not Application.Intersect(Target, Range("A1:ZZ1")) Is Nothing Then
' Ce If permet de ne pas selectionner la ligne1 et de renvoyer directement à la ligne 2 si c'est le cas. Cela marche avec les macros aussi
 
Range("A" & (ActiveCell.Row + 1)).EntireRow.Select
 
End If
 
 
If Selection.Cells.Count = 256 And ActiveCell.Row = 1 Then ActiveCell.Select
End Sub

Code this workbook:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
Private Sub Workbook_Open()
 
Sheets("BD").Protect UserInterfaceOnly:=True 'Protege la feuille de toutes les actions utilisateurs mais les macros peuvent modifier les cellules. Il est possible de rajouter un mot de passe à cette fonction.
 
 
 
Sheets("BD2").Visible = False
 
End Sub
 
 
Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Application.DisplayAlerts = False
    Sh.Delete
    Application.DisplayAlerts = True
End Sub

Code userform appelée "AJOUT"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Private Sub UserForm_Initialize()
 
Application.ScreenUpdating = False
 
Me.ComboBox1.AddItem "En Stock" 'Combobox permettant un affichage par défaut
Me.ComboBox1.AddItem "Prise"
ComboBox1.Style = fmStyleDropDownList
ComboBox1.ListIndex = 0
 
 
ComboBox2.Font.Size = 8 'Combobox des pathogenes, cette ligne sert à definir la taille de police
Me.ComboBox2.AddItem "ADV"
Me.ComboBox2.AddItem "Escherichia coli"
Me.ComboBox2.AddItem "HSV-1"
Me.ComboBox2.AddItem "HSV-2"
Me.ComboBox2.AddItem "Staphylococcus aureus"
Me.ComboBox2.AddItem "Staphylococcus epidermidis"
Me.ComboBox2.AddItem "Staphylococcus haemolyticus"
Me.ComboBox2.AddItem "VZV"
 
 
ComboBox3.Font.Size = 8 'Combobox des fournisseurs, cette ligne sert à definir la taille de police
Me.ComboBox3.AddItem "ATCC"
Me.ComboBox3.AddItem "WHO"
Me.ComboBox3.AddItem "Zeptometrix"
 
 
ComboBox4.Font.Size = 8 'Combobox des fournisseurs, cette ligne sert à definir la taille de police
 
 
Sheets("BD2").Visible = True 'Rendre visible BD2
Sheets("BD2").Range("D:D").Delete 'Supprimer la colonne D
Sheets("BD").Range("G2:G10000").Copy Sheets("BD2").Columns(2)
Sheets("BD2").Activate
 
 
 
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
 
 
TC = Range("A1:A10000") 'définit le tableau de cellules TC
NL = UBound(TC, 1) 'définit le nombre de lignes NL du tableau de cellules TC
For I = 1 To NL 'boucle sur toutes les lignes I du tableau de cellules TC
    'condition si la recherche R (recherche entière de la valeur ligne I colonne 1 de TC dans la colonne 2) renvoie au moins une occurrence trouvée
    If Columns(2).Find(TC(I, 1), , xlValues, xlWhole) Is Nothing Then
        ''definit la cellule de destination DEST (D1 si D1 est vide, sinon la première cellule vide de la colonne D)
        Set DEST = IIf(Range("D1").Value = "", Range("D1"), Cells(Application.Rows.Count, 4).End(xlUp).Offset(1, 0))
        DEST.Value = TC(I, 1) 'récupère dans DEST la valeur ligne I colonne 1 de TC
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
 
 
 
Columns("D:D").Select 'Ce paragraphe sert à trier la
    ActiveWorkbook.Worksheets("BD2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("BD2").Sort.SortFields.Add2 Key:=Range("D1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("BD2").Sort
        .SetRange Range("D1:D10000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
ActiveSheet.Range("$D$1:$D$10000").RemoveDuplicates Columns:=1, Header:=xlNo
ComboBox4.RowSource = "BD2!D1:D10000"
ComboBox4.Style = fmStyleDropDownList
 
 
Sheets("BD").Activate
Sheets("BD2").Visible = False
 
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'Permet de désactiver la croix rouge en haut à droite des fenetres userform.
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
 
Sub CommandButton1_Click()
 
 
 
If ComboBox2 = "" Or TextBox2 = "" Or TextBox3 = "" Or ComboBox3 = "" Or TextBox5 = "" Or TextBox6 = "" Or ComboBox4 = "" Or ComboBox1 = "" Or TextBox7 = "" Then
    MsgBox "Vous devez remplir tous les champs"
    Exit Sub
End If
 
ligne = Sheets("BD").[A65000].End(xlUp).Row + 1
 
Sheets("BD").Cells(ligne, 1) = ComboBox2.Value ' Cela permet de mettre les valeurs textbox dans mes cellules
    Sheets("BD").Cells(ligne, 2) = TextBox2.Value
    Sheets("BD").Cells(ligne, 3) = ComboBox3.Value
    Sheets("BD").Cells(ligne, 4) = TextBox3.Value
    Sheets("BD").Cells(ligne, 5) = TextBox5.Value
    Sheets("BD").Cells(ligne, 6) = TextBox6.Value
    Sheets("BD").Cells(ligne, 7) = ComboBox4.Value
    Sheets("BD").Cells(ligne, 8) = ComboBox1.Value
    Sheets("BD").Cells(ligne, 9) = TextBox7.Value
 
 
ComboBox2.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
ComboBox3.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
ComboBox4.Value = ""
ComboBox1.Value = ""
TextBox7.Value = ""
 
Application.ScreenUpdating = False
 
Sheets("BD2").Visible = True
Sheets("BD2").Range("D:D").Delete
 
 
Sheets("BD").Range("G2:G10000").Copy Sheets("BD2").Columns(2)
Sheets("BD2").Activate
 
 
 
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
 
 
TC = Range("A1:A10000") 'définit le tableau de cellules TC
NL = UBound(TC, 1) 'définit le nombre de lignes NL du tableau de cellules TC
For I = 1 To NL 'boucle sur toutes les lignes I du tableau de cellules TC
    'condition si la recherche R (recherche entière de la valeur ligne I colonne 1 de TC dans la colonne 2) renvoie au moins une occurrence trouvée
    If Columns(2).Find(TC(I, 1), , xlValues, xlWhole) Is Nothing Then
        ''definit la cellule de destination DEST (D1 si D1 est vide, sinon la première cellule vide de la colonne D)
        Set DEST = IIf(Range("D1").Value = "", Range("D1"), Cells(Application.Rows.Count, 4).End(xlUp).Offset(1, 0))
        DEST.Value = TC(I, 1) 'récupère dans DEST la valeur ligne I colonne 1 de TC
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
 
 
Range("D1:D10000").Sort Key1:=Range("D1"), Order1:=xlAscending
    ActiveSheet.Range("$D$1:$D$10000").RemoveDuplicates Columns:=1, Header:=xlNo
 
 
 
Sheets("BD").Activate
Range("A2:M10000").Sort Key1:=Range("A2"), Order1:=xlAscending 'Permet de trier par ordre alphabetique les souches
 
Sheets("BD2").Visible = False
Application.ScreenUpdating = True
MsgBox "Votre souche a bien été encodée"
 
ComboBox1.ListIndex = 0 'permet de remettre une valeur par defaut à la combobox apres avoir ajouté un pathogene une premiere fois.
 
End Sub
 
Private Sub CommandButton2_Click()
 
Range("A2:M10000").Sort Key1:=Range("A2"), Order1:=xlAscending 'Permet de trier par ordre alphabetique les souches
 
Range("A1:A1").Select 'Selectionne la cellule, ajout de cette ligne suite à un bug et cette ligne règle le bug comme par magie...
 
ThisWorkbook.Save ' sauvegarde le classeur, empechant l'utilisateur de fermer le classeur sans sauvegarder. Empeche la perte d'information
 
Unload Me
 
End Sub

Code userform1:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Private O As Worksheet 'déclare la variable O (Onglet)
Private TC As Variant 'déclare la variable TC (Tableau de Cellules)
Private NL As Integer 'déclare la variable NL (Nombre de Lignes)
Private NC As Byte 'déclare la variable NC (Nombre de colonnes)
 
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'Permet de désactiver la croix rouge en haut à droite des fenetres userform.
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
 
 
Private Sub CommandButton2_Click()
 
Range("A1:A1").Select 'Selectionne la cellule, ajout de cette ligne suite à un bug et cette ligne règle le bug comme par magie...
 
Unload Me 'vide et ferme l'UserForm
 
End Sub
 
Private Sub UserForm_Initialize() 'à l'initialisation de l'UserForm
 
 
Set O = Sheets("BD") 'définit l'onglet O
TC = O.Range("A1").CurrentRegion 'définit le tableau de cellules TC
NL = UBound(TC, 1) 'définit le nombre de lignes de TC
NC = UBound(TC, 2) 'définit le nombre de colonnes de TC
Me.ListBox1.ColumnCount = NC + 1 'définit le nombre de colonnes de la ListBox1 (à adapter, dans cet exemple je recherche dans la ligne entière. +1 pour le numéro de ligne)
Me.ListBox1.ColumnWidths = "0 pt;" 'masque la première colonne de la ListBox1 (celle ou sera stocké le numéro de la ligne)
 
 
End Sub
 
Private Sub TextBox1_Change() 'au changement dans la TesxBox1
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
 
Me.ListBox1.Clear 'vide la ListBox1
K = 1 'initialise la variable K
For I = 2 To NL 'boucle 1 : sur toutes les lignes I du tabelau de cellules TC (en partant de la seconde)
    For J = 1 To NC 'boucle 2 : sur toutes les colonnes J du tabelau de cellules TC
        If InStr(1, TC(I, J), Me.TextBox1.Value, vbTextCompare) <> 0 Then 'condition : si le texte de la TextBox1 est contenu dans la donnée ligne I colonne J (sans tenir compte de la casse)
            ReDim Preserve TL(NC + 1, 1 To K) 'redimensionne le tableau de lignes TL
            TL(0, K) = I 'récupère dans la ligne 0, colonne K de TL le numéro de ligne (masqué)
            For L = 1 To NC 'boucle sur toutes les colonnes de TC
                TL(L, K) = TC(I, L) 'récupère dans la ligne L, colonne K de TC la valeur de la ligne I , colonne L de TC (transposition)
            Next L 'prochaine colonne de la boucle 2
            K = K + 1 'incrémente K
            Exit For 'sort de la boucle 2
        End If 'fin de la condition
    Next J 'prochaine colonne de la boucle 2
Next I 'prochaine ligne de la boucle 1
If K > 1 Then 'condition : si K est supérieur à 1 (au moins une occurrence a été trouvé)
    If K = 2 Then ReDim Preserve TL(NC + 1, 1 To 2) 'si une seule occurrence trouvée, redimensionne TL pour pouvoir transposer
    Me.ListBox1.List = Application.Transpose(TL) 'alimente la ListBox1 avec le tableau TL transposé
End If 'fin de la condition
End Sub

Code userform2:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
 
Private rec As Range
 
Private Sub CommandButton1_Click()
 
If TextBox1 = "adenovirus" Or TextBox1 = "Adenovirus" Then  'Remplacement automatique par acronyme = uniformisation
TextBox1 = "ADV"
End If
 
   Set rec = Range("A2:A10000").Cells.Find("*" & Me.TextBox1.Value & "*", , xlValues, xlWhole) ' Permet de rechercher parmis la collone A un pathogène, les etoiles avant et après permettent d'avoir un résultat même si ce qui est écrit dans la textbox n'est pas le nom du pathogene complet
    If rec Is Nothing Then
        MsgBox "Recherche absente"
    Else
        Sheets("BD").Activate
        rec.EntireRow.Activate 'Selectionne la ligne qui a été trouvée
    End If
End Sub
 
 
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'Permet de désactiver la croix rouge en haut à droite des fenetres userform.
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
 
Private Sub CommandButton2_Click()
 
    If MsgBox("Êtes-vous sur de vouloir supprimer cette ligne?", vbYesNo, "Suppression de données") = vbYes Then
 
        ActiveCell.EntireRow.Delete 'Supprime la ligne qui est selectionnée
 
    End If
End Sub
 
Private Sub CommandButton3_Click()
 
Range("A" & (ActiveCell.Row - 1)).EntireRow.Select 'Permet d'aller selectionner la ligne au dessus de la ligne actuelle
 
End Sub
 
Private Sub CommandButton4_Click()
 
Range("A" & (ActiveCell.Row + 1)).EntireRow.Select 'Permet d'aller selectionner la ligne au dessous de la ligne actuelle
 
End Sub
 
Private Sub CommandButton5_Click()
 
Range("A1:A1").Select 'Selectionne la cellule, ajout de cette ligne suite à un bug et cette ligne règle le bug comme par magie...
 
ThisWorkbook.Save ' sauvegarde le classeur, empechant l'utilisateur de fermer le classeur sans sauvegarder. Empeche la perte d'information
 
Unload Me
 
End Sub
 
 
Sub UserForm_Initialize()
 
Range("A2:M10000").Sort Key1:=Range("A2"), Order1:=xlAscending 'Permet de trier par ordre alphabetique les souches
 
Range("A1:A1").Select 'Selectionne la cellule, ajout de cette ligne suite à un bug et cette ligne règle le bug comme par magie...
 
 
End Sub

Code userform3:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
 
Private rec As Range
 
Private Sub CommandButton1_Click()
 
    If TextBox1.Value = "adenovirus" Or TextBox1.Value = "Adenovirus" Then  'Remplacement automatique par acronyme = uniformisation
        TextBox1.Value = "ADV"
    End If
 
    Set rec = Range("A2:A10000").Cells.Find("*" & Me.TextBox1.Value & "*", , xlValues, xlWhole) ' Permet de rechercher parmis la collone A un pathogène, les etoiles avant et après permettent d'avoir un résultat même si ce qui est écrit dans la textbox n'est pas le nom du pathogene complet
    If rec Is Nothing Then
        MsgBox "Recherche absente"
    Else
        Sheets("BD").Activate
        rec.Cells.Activate 'Selectionne la ligne qui a été trouvée
    End If
End Sub
 
Sub CommandButton2_Click()
 
    If MsgBox("Êtes-vous sur de vouloir modifier cette ligne?", vbYesNo, "Suppression de données") = vbYes Then ' Ouvre un msg box qui confirme l'ouverture du userform4
 
    TextBox1.Value = ""
 
        UserForm4.Show
    End If
 
End Sub
 
Private Sub CommandButton3_Click()
 
Range("A" & (ActiveCell.Row - 1)).EntireRow.Select 'Permet d'aller selectionner la ligne au dessus de la ligne actuelle
 
 
End Sub
 
Private Sub CommandButton4_Click()
 
Range("A" & (ActiveCell.Row + 1)).EntireRow.Select 'Permet d'aller selectionner la ligne au dessous de la ligne actuelle
 
End Sub
 
Private Sub CommandButton5_Click()
 
Range("A2:M10000").Sort Key1:=Range("A2"), Order1:=xlAscending 'Permet de trier par ordre alphabetique les souches
 
Range("A1:A1").Select 'Selectionne la cellule, ajout de cette ligne suite à un bug et cette ligne règle le bug comme par magie...
 
ThisWorkbook.Save ' sauvegarde le classeur, empechant l'utilisateur de fermer le classeur sans sauvegarder. Empeche la perte d'information' sauvegarde le classeur, empechant l'utilisateur de fermer le classeur sans sauvegarder. Empeche la perte d'information
 
Unload Me
 
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'Permet de désactiver la croix rouge en haut à droite des fenetres userform.
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
 
Private Sub CommandButton6_Click()
 
Dim Val123 As Variant
 
    If MsgBox("Êtes-vous sur de vouloir remettre cette souche?", vbYesNo, "Suppression de données") = vbYes Then
 
        ligne = ActiveCell.Offset(0, 7).Select ' la cellule selectionnée est toujours collone A, cela permet de selectionnéela cellule de la collone diponibilité dans la ligne choisie
            If ActiveCell.Value = "Prise" Then
                UserForm5.Show
                ActiveCell.Value = "En Stock"
                MsgBox "Vous avez remis la souche"
                ActiveCell.Offset(0, -7).Select 'reviens dans la collone A
 
             Else
                MsgBox "Erreur: la souche est déjà en stock"
                ActiveCell.Offset(0, -7).Select
 
            End If
    End If
End Sub
 
Private Sub CommandButton7_Click()
 
    If MsgBox("Êtes-vous sur de vouloir prendre cette souche?", vbYesNo, "Suppression de données") = vbYes Then
 
        ligne = ActiveCell.Offset(0, 7).Select ' la cellule selectionnée est toujours collone A, cela permet de selectionnéela cellule de la collone diponibilité dans la ligne choisie
            If ActiveCell.Value = "En Stock" Then
                UserForm5.Show
                ActiveCell.Value = "Prise"
                MsgBox "Vous avez pris la souche"
                ActiveCell.Offset(0, -7).Select 'reviens dans la collone A
 
             Else
                MsgBox "Erreur: la souche est déjà prise"
                ActiveCell.Offset(0, -7).Select
 
 
            End If
    End If
 
End Sub

Code userform4:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
 
Private Val1 As Variant
Private Val2 As Variant
Private Val3 As Variant
Private Val4 As Variant
Private Val5 As Variant
Private Val6 As Variant
Private Val7 As Variant
Private Val8 As Variant
Private Val10 As Variant
 
Private Sub CommandButton2_Click()
 
Application.ScreenUpdating = False
 
    If ComboBox4 = "" Or TextBox8 = "" Or TextBox10 = "" Or ComboBox3 = "" Or TextBox11 = "" Or TextBox12 = "" Or ComboBox2 = "" Or ComboBox1 = "" Or TextBox13 = "" Then
MsgBox "Vous devez remplir tous les champs"
Exit Sub
End If
 
    ligne = Sheets("BD").[A65000].End(xlUp).Row + 1
 
    Sheets("BD").Cells(ligne, 1) = ComboBox4.Value ' Permet de mettre les valeurs des textbox dans les cellules excel
    Sheets("BD").Cells(ligne, 2) = TextBox8.Value
    Sheets("BD").Cells(ligne, 3) = ComboBox3.Value
    Sheets("BD").Cells(ligne, 4) = TextBox10.Value
    Sheets("BD").Cells(ligne, 5) = TextBox11.Value
    Sheets("BD").Cells(ligne, 6) = TextBox12.Value
    Sheets("BD").Cells(ligne, 7) = ComboBox2.Value
    Sheets("BD").Cells(ligne, 8) = ComboBox1.Value
    Sheets("BD").Cells(ligne, 9) = TextBox13.Value
 
Sheets("BD2").Visible = True
Sheets("BD2").Range("D:D").Delete
 
Sheets("BD").Range("G2:G10000").Copy Sheets("BD2").Columns(2)
Sheets("BD2").Activate
 
 
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim NL As Integer 'déclare la variable NL (Nombre de Lignes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim R As Range 'déclare la variable R (Recherche)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
 
 
TC = Range("A1:A10000") 'définit le tableau de cellules TC
NL = UBound(TC, 1) 'définit le nombre de lignes NL du tableau de cellules TC
For I = 1 To NL 'boucle sur toutes les lignes I du tableau de cellules TC
    'condition si la recherche R (recherche entière de la valeur ligne I colonne 1 de TC dans la colonne 2) renvoie au moins une occurrence trouvée
    If Columns(2).Find(TC(I, 1), , xlValues, xlWhole) Is Nothing Then
        ''definit la cellule de destination DEST (D1 si D1 est vide, sinon la première cellule vide de la colonne D)
        Set DEST = IIf(Range("D1").Value = "", Range("D1"), Cells(Application.Rows.Count, 4).End(xlUp).Offset(1, 0))
        DEST.Value = TC(I, 1) 'récupère dans DEST la valeur ligne I colonne 1 de TC
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
 
 
 
Columns("D:D").Select
    ActiveWorkbook.Worksheets("BD2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("BD2").Sort.SortFields.Add2 Key:=Range("D1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("BD2").Sort
        .SetRange Range("D1:D10000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$D$1:$D$10000").RemoveDuplicates Columns:=1, Header:=xlNo
 
 
Sheets("BD2").Visible = False
Sheets("BD").Range("A2:M10000").Sort Key1:=Range("A2"), Order1:=xlAscending 'Permet de trier les souches par ordre alphabetique
 
MsgBox "Votre souche a bien été modifiée"
 
Range("A1:A1").Select 'Selectionne la cellule, ajout de cette ligne suite à un bug et cette ligne règle le bug comme par magie...
 
ThisWorkbook.Save ' sauvegarde le classeur, empechant l'utilisateur de fermer le classeur sans sauvegarder. Empeche la perte d'information' sauvegarde le classeur, empechant l'utilisateur de fermer le classeur sans sauvegarder. Empeche la perte d'information
 
Unload Me
 
End Sub
 
 
Private Sub CommandButton3_Click()
 
ComboBox4.Value = Val1
TextBox8.Value = Val2
ComboBox3.Value = Val3
TextBox10.Value = Val4
TextBox11.Value = Val5
TextBox12.Value = Val6
ComboBox2.Value = Val7
ComboBox1.Value = Val8
TextBox13.Value = Val10
 
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'Permet de désactiver la croix rouge en haut à droite des fenetres userform.
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
 
Sub UserForm_Initialize()
 
Me.ComboBox1.AddItem "En Stock"
Me.ComboBox1.AddItem "Prise"
 
ComboBox1.Style = fmStyleDropDownList
 
Me.ComboBox4.AddItem "ADV"
Me.ComboBox4.AddItem "Escherichia coli"
Me.ComboBox4.AddItem "HSV-1"
Me.ComboBox4.AddItem "HSV-2"
Me.ComboBox4.AddItem "Staphylococcus aureus"
Me.ComboBox4.AddItem "Staphylococcus epidermidis"
Me.ComboBox4.AddItem "Staphylococcus haemolyticus"
Me.ComboBox4.AddItem "VZV"
 
 
Me.ComboBox3.AddItem "ATCC"
Me.ComboBox3.AddItem "WHO"
Me.ComboBox3.AddItem "Zeptometrix"
 
Sheets("BD2").Visible = True
ComboBox2.RowSource = "BD2!D1:D10000"
Sheets("BD2").Visible = False
 
Val1 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
ComboBox4.Value = Val1
ActiveCell.Offset(0, 1).Select
 
Val2 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
TextBox8.Value = Val2
ActiveCell.Offset(0, 1).Select
 
Val3 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
ComboBox3.Value = Val3
ActiveCell.Offset(0, 1).Select
 
Val4 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
TextBox10.Value = Val4
ActiveCell.Offset(0, 1).Select
 
Val5 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
TextBox11.Value = Val5
ActiveCell.Offset(0, 1).Select
 
Val6 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
TextBox12.Value = Val6
ActiveCell.Offset(0, 1).Select
 
Val7 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
ComboBox2.Value = Val7
ActiveCell.Offset(0, 1).Select
 
Val8 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
ComboBox1.Value = Val8
ActiveCell.Offset(0, 1).Select
 
Val10 = ActiveCell.Value ' Permet de mettre une valeur par defaut à la textbox. La valeur par defaut est ce qui contient la cellule
TextBox13.Value = Val10
 
 
ActiveCell.EntireRow.Delete 'On supprime la ligne, mais la valeurs des cellules contenue dans la ligne se trouvent dans les textbox de l'userform4
 
End Sub

Code Userform5:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
 
Private Sub CommandButton1_Click()
 
If TextBox1 = "" Then
    MsgBox "Vous devez remplir le champs"
    Exit Sub
End If
 
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = TextBox1.Value
ActiveCell.Offset(0, -1).Select
 
Unload Me
 
End Sub
 
Private Sub TextBox1_Change()
 
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'Permet de désactiver la croix rouge en haut à droite des fenêtres userform.
    If CloseMode = vbFormControlMenu Then Cancel = True
End Sub

Désolé d'être passé à coté de certaines recommandations du forum. Il est compliqué de toutes les suivre du premier coup, je ferai plus attention à l'avenir.
Merci d'avoir pris le temps de répondre, au moins vous m'avez appris des règles du forum.

Liathe

**mfoxy** · 13/03/2020, 10h08

Bonjour,

En effet, bcp de travail fait sur ton projet.

Cependant, et au risque de te déplaire, c'est assez loin de respecter les bonnes règles de programmation au niveau des userform.

Je ne peu que vivement te conseiller la lecture de quelques tutoriels à fin de mieux comprendre mon propos.

https://www.developpez.net/forums/bl...tion-userform/

https://fauconnier.developpez.com/tu...eau-structure/

Tu pourras de cette façon pérenniser ton projet et corriger plus facilement les bugs

**Liathe** · 13/03/2020, 11h46

Bonjour mfoxy,

Merci de participer à cette discussion ainsi que pour tes liens, que je n'ai pas l'impression de comprendre à 100%. Je ne suis pas dans le domaine informatique du tout, et j'ai appris VBA avec des tutos et des essais/erreurs (beaucoup d'erreurs d'ailleurs).

Celà ne me déplait pas, au contraire, si je peux apprendre les bonnes pratique de programmation, je suis preneur! Mais comme dit plus haut, je n'ai pas tout compris, si tu as des tutos sur les bonnes pratiques plus axés pour les débutants je les lirai, corrigerai mon code au mieux et je vous remettrai mon code ici.

Je ne vois pas exactement où tu veux en venir. Si pour que se soit plus clair, je dois déclarer mes variables au début du code, je le ferai. Mais je ne vois pas le problème de les déclarer juste avant de les utiliser. (Ceci est un exemple)

Concernant la validation "technique", celà a déjà été fait. Si pour certains textboxs je laisse à l'utilisateur le choix de ce qu'il veut mettre c'est fait exprès. Sinon j'aurais mis une combobox avec une valeur par défaut et obliger l’utilisateur de sélectionner une valeur de la liste. Certaines combobox servent aussi à juste faire une suggestion à l'utilisateur et ne sont pas restrictive.

Ma macro fonctionne comme je le veux et n'a pas de bug (pas à ma connaissance).

Liathe

**mfoxy** · 13/03/2020, 12h13

Re,

Je trouve que pour un débutant, tu t'es déjà très bien débrouiller, et je t'en félicite.

Je suppose, que comme tout le monde, tu as du chercher, t'inspirer, tester des solutions trouver par ci par là sur le net à fin d'arriver la ou tu en es.

Mon post était la uniquement que pour te diriger vers des tutoriels que offre des conseils et méthodes plus proffesional d'utiliser, manipuler, des données par userform.

Je constate pour ma part directement deux "gros" souci dans tes codes postés.

1) tes contrôles, textbox, combobox, sont très difficilement identifiable, généralement pour une meilleur lisibilité, on les renommé.
Par exemple pour une textbox devant contenir un prénom tboFirstName, tbo pour textbox, FirstName pour prénom.

2) dans le code de ton userform, il y a des traitements ( par exemple lors de l'ajout d'info dans ta feuille)

Un userform ne devrait dans la mesure du possible, uniquement passé des infos dans une procédure contenue dans un module tiers.

Je n'ai malheureusement pas le temps de te démontrer mes propos en revoyant l'entièreté de ton outils, mais le fichier dans le tuto de Pierre "interaction usf et table structuré" est un des exemples les plus probants.

Optimisation de macro VBA

Macros et VBA Excel

Discussions similaires

Partager

Partager