Bonjour a tous
j'en appel aux experts VBA, j'ai grâce a différents tuto construit un fichier pour gérer une base de contact.
Ce fichier comporte un formulaire pour saisie de nouveaux contact, modification de contact existant, et bien sur suppression.
j'ai un bug que je n'arrive pas a corriger car a l'ajout de nouveau patient en logique je devrais ajouter celui ci dans mon tableau à partir de la ligne 22, mais la il me positionne cela en ligne 23 et va même me supprimer des contact déjà présent???
Je vous joins ci dessous la version sans données, car celle ci sont confidentiel
Petite question tout me semblait bien fonctionner et j'ai du coup par le biais d'un copier coller ajouter dans la base 500 contacts.
Si quelqu'un pouvait m'aider a comprendre mon erreur ce serait sympa. Merci d'avance a ceux qui prendront du temps pour m'accompagner.
Prenez soin de vous
Merci
Test pour consulation 2021 V2 sans données.xlsm
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 Function NvLigne() Dim ligne As Integer ligne = 22 Do While Cells(ligne, 2).Value <> "" ligne = ligne + 1 If (ligne > 10000) Then Exit Do Loop NvLigne = ligne End Function Function ClExiste() As Boolean Dim ligne As Integer ligne = 22: ClExiste = False Do While Cells(ligne, 2).Value <> "" If (Range("B" & ligne).Value = Range("B3").Value And Range("C" & ligne).Value = Range("D3").Value) Then ClExiste = True Exit Do End If ligne = ligne + 1 If (ligne > 10000) Then Exit Do Loop End Function
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 Dim lignesel As Integer Private Sub Ajouter_Click() insertion ("Ajout") End Sub Private Sub Deverouiller_Click() ActiveSheet.Unprotect End Sub Private Sub Modifier_Click() insertion ("Modif") End Sub Private Sub insertion(mode As String) Dim ligne As Integer: Dim test As Boolean test = False If (Range("P8").Value >= 0) Then 'vérifie si tous les champs sont bien a o et non pas Nok, cette vérification se fait sur la cellule P9 dans cet exemple' If (mode = "Ajout") Then ligne = NvLigne If (ClExiste = True) Then test = True Else ligne = lignesel End If ActiveSheet.Unprotect 'supprime la protection de le feuille active' If test = False Then Range("B" & ligne).Value = Range("B3").Value 'fonction qui permet de récupérer N° secu affichage B=>B3' Range("C" & ligne).Value = Range("D3").Value 'fonction qui permet de récupérer Nom affichage C=>D3' Range("D" & ligne).Value = Range("G3").Value 'fonction qui permet de récupérer Prénom affichage D=>G3' Range("E" & ligne).Value = Range("D6").Value 'fonction qui permet de récupérer Date de naissance affichage E=>D6' Range("F" & ligne).Value = Range("N11").Value 'fonction qui permet de récupérer Age affichage F=>B6' Range("G" & ligne).Value = Range("G6").Value 'fonction qui permet de récupérer Téléphone affichage G=>G6' Range("H" & ligne).Value = Range("B12").Value 'fonction qui permet de récupérer Statut affichage H=>B12' Range("I" & ligne).Value = Range("D12").Value 'fonction qui permet de récupérer Grade affichage I=>D12' Range("J" & ligne).Value = Range("G12").Value 'fonction qui permet de récupérer Service affichage I=>D12' Range("K" & ligne).Value = Range("B9").Value 'fonction qui permet de récupérer Date de dernière visite affichage J=>B9' Range("L" & ligne).Value = Range("N12").Value 'fonction qui permet de récupérer Prochain RDV a 18mois affichage K=>D9' Range("M" & ligne).Value = Range("G9").Value 'fonction qui permet de récupérer Fin de contrat affichage L=>G9' Range("N" & ligne).Value = Range("B15").Value 'fonction qui permet de récupérer Commentaires affichage M=>B15' Range("O" & ligne).Value = Range("J3").Value 'fonction qui permet de récupérer Vaccin N°1 affichage N=>J3' Range("P" & ligne).Value = Range("K3").Value 'fonction qui permet de récupérer Date Rappel vaccin N°1 affichage O=>K3' Range("Q" & ligne).Value = Range("J4").Value 'fonction qui permet de récupérer Vaccin N°2 affichage P=>J4' Range("R" & ligne).Value = Range("K4").Value 'fonction qui permet de récupérer Date Rappel vaccin N°2 affichage Q=>K4' Range("S" & ligne).Value = Range("J5").Value 'fonction qui permet de récupérer Vaccin N°3 affichage R=>J5' Range("T" & ligne).Value = Range("K5").Value 'fonction qui permet de récupérer Date Rappel vaccin N°3 affichage S=>K5' Range("U" & ligne).Value = Range("J6").Value 'fonction qui permet de récupérer Vaccin N°4 affichage T=>J6' Range("V" & ligne).Value = Range("K6").Value 'fonction qui permet de récupérer Date Rappel vaccin N°4 affichage U=>K6' Range("W" & ligne).Value = Range("J7").Value 'fonction qui permet de récupérer Vaccin N°5 affichage V=>J7' Range("X" & ligne).Value = Range("K7").Value 'fonction qui permet de récupérer Date Rappel vaccin N°5 affichage W=>K7' Else MsgBox "Numéro de Securité Social déja dans la base" 'message a modifier en fonction des attentes' End If vider_form 'procédure pour vider le formulaire et démarrer un nouvel enregistrement' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True Else MsgBox "Merci de remplir un minimum de 3 champs" 'message a modifier en fonction des attentes' End If End Sub Private Sub vider_form() Range("B3").Value = "" 'fonction qui permet de vider les informations dans le formulaire affichage=>B3' Range("D3").Value = "" Range("G3").Value = "" Range("D6").Value = "" Range("B6").Value = "" Range("G6").Value = "" Range("B12").Value = "" Range("D12").Value = "" Range("G12").Value = "" Range("B9").Value = "" Range("D9").Value = "" Range("G9").Value = "" Range("B15").Value = "" Range("J3").Value = "" Range("K3").Value = "" Range("J4").Value = "" Range("K4").Value = "" Range("J5").Value = "" Range("K5").Value = "" Range("J6").Value = "" Range("K6").Value = "" Range("J7").Value = "" Range("K7").Value = "" End Sub Private Sub Supprimer_Click() Dim ligne As Integer ligne = lignesel If (ligne > 0) Then ActiveSheet.Unprotect 'supprime la protection de le feuille active' Do While Range("B" & ligne).Value <> "" Range("B" & ligne & ":X" & ligne).Value = Range("B" & ligne + 1 & ":X" & ligne + 1).Value ligne = ligne + 1 If (ligne > 10000) Then Exit Do Loop lignesel = 0 vider_form 'appel de la fonction vider le formulaire' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True 'active la protection de le feuille active' End If End Sub Private Sub Vider_Click() vider_form End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim ligne As Integer: Dim colonne As Integer ligne = Target.Row: colonne = Target.Column If (ligne >= 22 And colonne >= 2 And colonne <= 23) Then ' permet de selectionner la première ligne de la base dans l'exemple (Ligne 22) et sur le total de colonne (23) dans l'exemple B22=>X22' lignesel = ligne Range("B" & ligne & ":X" & ligne).Select ' pour mettre en surbrillance la ligne selectionner' Range("B3").Value = Range("B" & ligne).Value 'fonction qui permet de restituer la valeur de la ligne selectionné dans son champ respectif' Range("D3").Value = Range("C" & ligne).Value Range("G3").Value = Range("D" & ligne).Value Range("D6").Value = Range("E" & ligne).Value Range("B6").Value = Range("F" & ligne).Value Range("G6").Value = Range("G" & ligne).Value Range("B12").Value = Range("H" & ligne).Value Range("D12").Value = Range("I" & ligne).Value Range("G12").Value = Range("J" & ligne).Value Range("B9").Value = Range("K" & ligne).Value Range("D9").Value = Range("L" & ligne).Value Range("G9").Value = Range("M" & ligne).Value Range("B15").Value = Range("N" & ligne).Value Range("J3").Value = Range("O" & ligne).Value Range("K3").Value = Range("P" & ligne).Value Range("J4").Value = Range("Q" & ligne).Value Range("K4").Value = Range("R" & ligne).Value Range("J5").Value = Range("S" & ligne).Value Range("K5").Value = Range("T" & ligne).Value Range("J6").Value = Range("U" & ligne).Value Range("K6").Value = Range("V" & ligne).Value Range("J7").Value = Range("W" & ligne).Value Range("K7").Value = Range("X" & ligne).Value End If End Sub
Partager