Assistance et correction sur Macro

**Muzzik** · 09/04/2021, 09h20

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

**Pierre Fauconnier** · 09/04/2021, 10h18

Salut.

Je donne une explication à une demande similaire dans cette discussion. L'utilisation des références structurées t'aidera à créer un code lisible et maintenable.

Voici comment j'écrirais le code de la procédure qui transfère les données dans la table. Au passage, avec un tableau structuré, il n'est pas nécessaire de prévoir des lignes vides. C'est même contre-productif. J'ai donc supprimé les lignes en trop de ton tableau. Ca permet au code de trouver facilement la nouvelle ligne puisqu'on peut l'ajouter et en récupérer la position.

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
Private Sub insertion(mode As String)
  Dim ligne As Long
  Dim test As Boolean
 
  test = False
  If (Range("P8").Value = 3) Then 'vérifie si tous les champs sont bien a o et non pas Nok, cette verification se fait sur la cellule P9 dans cet exemple'
    ActiveSheet.Unprotect 'supprime la protection de le feuille active'
    If (mode = "Ajout") Then
    ligne = Range("tableau2").ListObject.ListRows.Add.Index
    If (ClExiste = True) Then test = True
  Else
      ligne = lignesel - Range("tableau2").Row + 1
  End If
 
 
 
  If test = False Then
    Range("tableau2[N° Sécurité Social]")(ligne).Value = Range("f_NumSoc").Value 'fonction qui permet de récupérer N° secu affichage B=>B3'
    Range("tableau2[Nom]")(ligne).Value = Range("f_Nom").Value 'fonction qui permet de récupérer Nom affichage C=>D3'
    ...
    ...

On pourrait améliorer d'autres choses dans le code, mais si déjà tu utilises le code proposé ci-dessus, ça résoudra ton problème de mauvaise ligne.

**Muzzik** · 09/04/2021, 17h53

Bonjour Pierre

Un grand merci de te pencher sur ma problématique.
si je comprends bien je modifie la liste en dessous de mon formulaire en structurant celui ci sous forme de tableau, par contre je n'ai pas bien compris, je dois définir un Nom a chaque entête de mon tableau structuré

N° Sécurité Social => F_NumSoc en lui faisant référence a lui même =Tableau2[[#En-têtes];[N° Sécurité Social]]
Nom => F_Nom
etc

Je debute en VBA, mais curieux d'apprendre et de bien faire.

Merci de ton aide

**Pierre Fauconnier** · 09/04/2021, 21h41

En fait, tes données sont déjà dans un tableau structuré (appelé aussi table, liste ou table dynamique). Donc ça c'est ok. Mais il y a trop de lignes (580) alors qu'un avantage du tableau structuré, c'est qu'il n'est pas nécessaire de prévoir des lignes pour les ajouts. Tu peux ajouter une ligne manuellement, par TAB ou par clic droit. De plus, en l'absence de ligne de total, saisir une donnée sur la ligne qui suit la dernière du tableau étend celui-ci à cette nouvelle ligne (selon les options par défaut d'Excel). De plus, ton code VBA bénéficie de cela car le tableau structuré en VBA dispose d'une méthode qui ajoute une ligne et permet de la traiter, notamment grâce à la propriété Index comme le montre mon code (range(...).ListObject.ListRows.Add.index). il serait intéressant de le renommer. Ici, je vais le renommer t_Data.

Les cellules F_NumSoc, f_Nom et f_Prenom utilisées dans mon code sont des cellules nommées donc la référence peut être utilisée dans le code (range("f_Nom")). Ce sont les cellules B3, D3, ... du "formulaire". Nommer ces cellules permet un appariement colonne du tableau/Cellule formulaire (range("t_Data[Nom]")(index).Value = range("f_Nom").value).

Lorsque cela est fait, on peut alors écrire le code qui transfère dans une nouvelle ligne (ou qui met une ligne à jour). A priori, c'est la même procédure qui sera utilisée pour les deux actions, car elle va recevoir l'index de la ligne sur laquelle écrire (l'index de la nouvelle pour un ajout et l'index retrouvé par une fonction spécifique pour une mise à jour)...

Idéalement, tes listes déroulantes (statut, service, grade) devraient s'appuyer sur des tableaux structurés elles aussi, avec une formule du type =INDIRECT("t_Grades[Grade]"). Ici, j'ai transformé la liste des grades en tableau t_Grades avec une colonne nommée Grade. J'ai fait de même pour les services et les statuts. Ca te dispense des formules nommées avec DECALER

Pour récupérer les données du tableau et les envoyer au formulaire, c'est la même logique que pour enregistrer les données. On trouve l'index d'une ligne (et on a déjà la fonction pour cela, que j'ai mise dans le code et qui tient sur une ligne) puis on transfère: range("f_Nom").value = range("t_Data[Nom]")(index).Value. La mécanique est en fait très claire à comprendre lorsque l'on utilise les noms des colonnes et des cellules du formulaire.

Pour le numéro de secsoc, je comprends bien l'intérêt d'une valeur de type numérique que l'on peut "formater" pour l'affichage. Dans le traitement VBA de cette donnée, vu qu'elle dépasse la capacité des entiers longs, ça pourrait poser problème. Perso, j'aurais choisi un format texte pour cette info car ce n'est en fait pas une info numérique au sens informatique du terme (on n'additionne pas des numéros de secsoc). Mais j'admets que c'est "pratique" (à la mode Excel) de formater du numérique.

Voici le fichier sur lequel j'ai travaillé. Il n'est évidemment ni nettoyé ni achevé, mais il te montrera "sur pièces" comment mon code fonctionne et tu pourras le transférer plus aisément dans ton application.

consultations_2021.xlsm

**Muzzik** · 10/04/2021, 11h25

Bonjour Pierre,

Merci du temps et de la patience, je vais reprendre avec les éléments transmis pour corriger/revoir la mise en forme.
Toutes les plages nommées en gestionnaire de nom, je vais refaire cela au propre, mais je peux conserver néanmoins les fonctions "=DECALER(P_statut;0;0;NBVAL(L_statut);1)" et celles utilisée dans le formulaire, pour faciliter les saisies ou cela n'a aucun intérêt.

Par contre petite question quand tout sera remis en forme je dois pour aider ma conjointe insérer 530 contacts déjà existant cela posera t'il un problème de copier coller ou cela n'aura pas d'incidence.

En tout cas je pense que je vais serieusement progresser avec tes super explications, merci beaucoup, je me mets de suite au travail et reviens vers toi avec quelque chose de plus aboutis je l'éspère.

Bien a toi

Christophe

**Pierre Fauconnier** · 10/04/2021, 13h14

Pour insérer les contacts par copier-coller, ça ne pose pas de problème avec un tableau structuré car Excel va adapter sa taille. Si tes données viennent d'une feuille Excel, je préconise le copier-coller spécial valeurs pour ne pas parasiter les formats du tableau et amener dans le classeur des données attachées aux cellules de la source et qui n'auraient rien à faire dans ton nouveau classeur.

Bon travail pour la suite. N'hésite pas à revenir nous dire bonjour au besoin

**Muzzik** · 10/04/2021, 19h30

Bonsoir Pierre

Et bien sur ceux qui liront ce message.
J'ai remis en forme avec les explications données, mais j'ai un petit bug, pourrais tu me dire si je suis bien partis dans la bonne direction.
j'ai une petite erreur que je n'arrive pas a corriger "Index = Range("T_data[N° Sécurité Social]").ListObject.ListRows.Add.Index" erreur d'execution 1004.

Pour valider mon travail jNew statistiques Consult 2021.xlsme te transmet celui ci.

Bien a toi

**Pierre Fauconnier** · 10/04/2021, 20h31

Salut.

En fait, lors de mon test, j'avais déjà déprotégé la feuille, de sorte que le problème est passé crème.

Normalement, ce sont les procédures Ajouter_Click et Modifier_Click qui devraient déverrouiller la feuille et la reverrouiller après traitement. Ca correspondrait à une meilleure architecture. Idéalement, ce sont elles aussi qui devraient tester que les données sont complètes. Là aussi, on a une architecture correcte, car la procédure Insertion ne doit avoir comme rôle que le transfert des données.

Du coup, voici comment je coderais les procédures:

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
Private Sub Ajouter_Click()
  Dim Index As Long
 
  On Error GoTo Catch
  If (Range("P8").Value = 3) Then
    If IndexLigne(Range("C_N°Sécu").Value) = 0 Then
      ActiveSheet.Unprotect
      Index = Range("T_data[N° Sécurité Social]").ListObject.ListRows.Add.Index
      insertion Index
    Else
      MsgBox "Ce numéro existe"
    End If
  Else
    MsgBox "Données incomplètes"
  End If
 
Catch:
  ActiveSheet.Protect
  If Err <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Erreur durant l'enregistrement"
End Sub
 
Private Sub Modifier_Click()
  Dim Index As Long
 
  On Error GoTo Catch
 
  If (Range("P8").Value = 3) Then
    Index = IndexLigne(Range("C_N°Sécu").Value)
    If Index > 0 Then
      ActiveSheet.Unprotect
      insertion Index
    Else
      MsgBox "Ce numéro n'existe pas"
    End If
  Else
    MsgBox "Données incomplètes"
  End If
 
Catch:
  ActiveSheet.Protect
  If Err <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Erreur durant l'enregistrement"
End Sub

La macro d'insertion se résume alors à une suite de transfert de cellules:

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
Private Sub insertion(Index As Long)
  Range("T_data[N° Sécurité Social]")(Index).Value = Range("C_N°Sécu").Value
  Range("T_data[Nom]")(Index).Value = Range("C_Nom").Value
  Range("T_data[Prénom]")(Index).Value = Range("C_Prénom").Value
  Range("T_data[Date de Naissance]")(Index).Value = Range("C_DateNaissance").Value
  Range("T_data[Age]")(Index).Value = Range("C_Age").Value
  Range("T_data[Numéro Téléphone]")(Index).Value = Range("C_Numtel").Value
  Range("T_data[Statut]")(Index).Value = Range("C_Statut").Value
  Range("T_data[Grade]")(Index).Value = Range("C_Grade").Value
  Range("T_data[Service]")(Index).Value = Range("C_Service").Value
  Range("T_data[Date de dernière visite Médicale]")(Index).Value = Range("C_Datevisite").Value
  Range("T_data[Prochain RDV à 18 Mois]")(Index).Value = Range("C_ProchainRDV").Value
  Range("T_data[Date de fin de Contrat]")(Index).Value = Range("C_FindeContrat").Value
  Range("T_data[Commentaires]")(Index).Value = Range("C_Commentaires").Value
  Range("T_data[BCG]")(Index).Value = Range("C_BCG").Value
  Range("T_data[Tubertest]")(Index).Value = Range("C_Tubertest").Value
  Range("T_data[Coqueluche]")(Index).Value = Range("C_Coqueluche").Value
  Range("T_data[Covid]")(Index).Value = Range("C_Covid").Value
  Range("T_data[DTP]")(Index).Value = Range("C_DTP").Value
  Range("T_data[Grippe]")(Index).Value = Range("C_Grippe").Value
  Range("T_data[Hépatite]")(Index).Value = Range("C_Hépatite").Value
  Range("T_data[ROR]")(Index).Value = Range("C_ROR").Value
  Range("T_data[Varicelle]")(Index).Value = Range("C_Varicelle").Value
  vider_form  'procédure pour vider le formulaire et démarrer un nouvel enregistrement'
End Sub

Tant que j'y étais, j'ai un peu remodelé le Worksheet_SelectionChange et la procédure de récupération des données du tableau vers le formulaire. La procédure de transfert DataVersFormulaire ne doit avoir qu'un seul rôle, le transfert (comme la procédure d'insertion). C'est le Worksheet_SelectionChange qui va retrouver la ligne (par simple différence arithmétique, désactiver l'écoute de SelectionChange (car dans cette procédure, tu sélectionnes des cellules => nouvel appel de l'évènement). Ces procédures sont bien entendu encadrées d'une gestion d'erreur pour remettre tout en ordre en fin de traitement.

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
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  ' Ici, on devrait appeler une fonction qui lit les données
  ' A nouveau, l'idée est de trouver la ligne du tableau comme index
  ' puis d'utiliser range("f_Nom").value = range("t_Data[Nom]")(Index).Value
  ' et ainsi de suite pour les autres lignes
 
  Dim Index As Long
 
  On Error GoTo Catch
 
  If Not Intersect(Target, Range("t_Data[N° Sécurité Social]")) Is Nothing 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'
    Application.EnableEvents = False
    Index = Target.Row - Range("t_Data[#Headers]").Row
    Range("t_Data").ListObject.ListRows(Index).Range.Select ' pour mettre en surbrillance la ligne selectionner'
    DataVersFormulaire Index
  End If
 
Catch:
  Application.EnableEvents = True
End Sub
 
Sub DataVersFormulaire(Index As Long)
  Range("C_N°Sécu").Value = Range("T_data[N° Sécurité Social]")(Index).Value
  Range("C_Nom").Value = Range("T_data[Nom]")(Index).Value
  Range("C_Prénom ").Value = Range("T_data[Prénom]")(Index).Value
  Range("C_DateNaissance").Value = Range("T_data[Date de Naissance]")(Index).Value
  Range("C_Age").Value = Range("T_data[Age]")(Index).Value
  Range("C_Numtel").Value = Range("T_data[Numéro Téléphone]")(Index).Value
  Range("C_Statut").Value = Range("T_data[Statut]")(Index).Value
  Range("C_Grade").Value = Range("T_data[Grade]")(Index).Value
  Range("C_Service").Value = Range("T_data[Service]")(Index).Value
  Range("C_Datevisite").Value = Range("T_data[Date de dernière visite Médicale]")(Index).Value
  Range("C_ProchainRDV").Value = Range("T_data[Prochain RDV à 18 Mois]")(Index).Value
  Range("C_FindeContrat").Value = Range("T_data[Date de fin de Contrat]")(Index).Value
  Range("C_Commentaires").Value = Range("T_data[Commentaires]")(Index).Value
  Range("C_BCG").Value = Range("T_data[BCG]")(Index).Value
  Range("C_Tubertest").Value = Range("T_data[Tubertest]")(Index).Value
  Range("C_Coqueluche").Value = Range("T_data[Coqueluche]")(Index).Value
  Range("C_Covid").Value = Range("T_data[Covid]")(Index).Value
  Range("C_DTP").Value = Range("T_data[DTP]")(Index).Value
  Range("C_Grippe").Value = Range("T_data[Grippe]")(Index).Value
  Range("C_Hépatite").Value = Range("T_data[Hépatite]")(Index).Value
  Range("C_ROR").Value = Range("T_data[ROR]")(Index).Value
  Range("C_Varicelle").Value = Range("T_data[Varicelle]")(Index).Value
End Sub

New statistiques Consult 2021_Pierre.xlsm

Attention que dans ton fichier, la colonne Tubertest était "mal nommée" car un espace trainait à droite du mot. J'ai corrigé dans le fichier que je te remets. A toi à corriger dans ton fichier

**Muzzik** · 10/04/2021, 22h48

Super merci de ton retour

Mais j'ai encore besoin de tes lumières pour finaliser la procédure de suppression
Je ne comprends pas et ne sais pas faire cette partie
Quand tu parles de récupérer l'index j'avoue ne pas savoir faire mais je suis certain que tes lumières vont m'éclairer

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
Private Sub Supprimer_Click()
  ' Ici, on peut aussi récupérer l'index de la ligne à supprimer
  ' puis on peut utiliser Range("t_Data").listobject.listrows(Index).delete
 
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 & ":W" & ligne).Value = Range("B" & ligne + 1 & ":W" & 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

J'ai appliqué ton conseil pour raccourcir la procédure vider_form 'Range("F_viderform").Value = ""'
Je te remercie pour ses conseils qui me font progresser.

**Pierre Fauconnier** · 11/04/2021, 11h45

Dans une application telle que celle que tu développes, l'idée est de s'appuyer systématiquement sur les tableaux structurés pour le code en VBA. Dans cette optique, la position d'une ligne par rapport au tableau (et pas par rapport à la feuille) est un élément central. C'est le rôle de la variable Index que j'utilise (ce nom est arbitraire, on aurait pu l'appeler NumeroLigne).

On peut calculer cet index de plusieursfaçons:
en s'appuyant sur un indice du tableau, idéalement une valeur unique comme le numéro de secsoc, ce qui est réalisé par la fonction IndexLigne du module 1 qui utilise Evaluate et EQUIV (MATCH en anglais);
en cherchant cet index via une formule conditionnelle en VBA (en gros un EQUIV plus évolué multi-critères);
en retrouvant cet index par la cellule active si celle-ci est située dans le tableau, comme je le montre dans le code suivant.

Voici le code du bouton Supprimer qui travaille sur la cellule active. Idéalement, on devrait isoler la suppression proprement dite du code du bouton, mais on peut rester simple aussi.

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
Private Sub Supprimer_Click()
  Dim Index As Long
  Dim Answer As VbMsgBoxResult
 
  On Error GoTo Catch
  Application.EnableEvents = False
  If Not Intersect(ActiveCell, Range("t_Data")) Is Nothing Then
    Answer = MsgBox("Voulez-vous supprimer cette ligne?", vbQuestion + vbYesNo, "Suppression d'un enregistrement")
    If Answer = vbYes Then
      ActiveSheet.Unprotect
      Index = ActiveCell.Row - Range("t_Data[#headers]").Row
      Range("t_Data").ListObject.ListRows(Index).Delete
    End If
  End If
 
Catch:
  ActiveSheet.Protect
  Application.EnableEvents = True
  If Err <> 0 Then MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Erreur durant la suppression"
End Sub

**Muzzik** · 11/04/2021, 16h10

Bonjour Pierre,

Un IMMENSE Merci pour ta pédagogie et tes conseils, je viens de finaliser mon travail grâce a ton expertise.
Sans tes conseils et ta méthodologie j'y serais encore.

Maintenant que j'ai finis le travail pour ma chère et tendre épouse, elle va avoir enfin une base pour suivre correctement ses patients.
Plus qu'a maintenant reproduire ce travail pour me faire ma BDD de prospection et suivi de mes propres clients & contacts.

Encore Merci pour ton aide.
Bien a toi

Christophe

**Muzzik** · 11/04/2021, 17h16

Bonsoir Pierre,

J'ai ajouté les 520 contacts dans la base, mais je n'ai pas pensé que le controle est actuellement établi sur
Index = IndexLigne(Range("C_N°Sécu").Value), sauf que justement ce travail est réalisé pour que mon épouse puisse mettre a jour et faire vivre cette base.
A ce jour je n'ai pas l'ensemble des N°Sécu, par contre j'ai l'ensemble des Nom & Prénom, penses tu que nous puissions modifier pour effectuer un controle sur plusieurs items.
Car apres test il s'avère que si je modifie un contact sans avoir son N°Sécu il m'en crée un nouveau donc j'ai des doublons,...

Souhaites tu que je te transmette le fichier finalisé

Cordialement

**Pierre Fauconnier** · 11/04/2021, 20h23

En fait, j'ai pensé hier que si tu amènes les données par copier-coller, il faut faire attention que l'écoute de l'évènement Selection_Change pourrait perturber ton copier-coller et qu'il conviendrait de désactiver temporairement cette écoute. Dans la fenêtre d'exécution (CTRL+G), tu pourrais saisir Application.EnableEvents = False le temps du transfert puis, toujours par cette fenêtre, le remettre à True après le transfert.

Evidemment, le numéro de secsoc est intéressant puisque unique, mais il faut effectivement qu'il soit renseigné sans cela, tous les numéros vides sont potentiellement des doublons. Réaliser le test de doublons sur le couple Nom-Prénom est tentant, mais si ton épouse a deux Jean Dupont dans sa patientèle, ça va poser problème. La date de naissance, si elle est toujours connue, pourrait être jointe au couple Nom-Prénom pour tester le doublon.

Une autre solution pourrait être de renseigner un numéro "interne" en absence de numéro national (une simple incrémentation en partant de 1 pourrait suffire puisqu'il n'y aurait pas de risque de collision avec un numéro secsoc. Autre idée encore, établir systématiquement un numéro de patient, indépendamment du numéro de secsoc.

Il faudrait voir avec ton épouse ce qu'elle en pense avant de partir sur une solution technique.

**Muzzik** · 11/04/2021, 22h08

effectivement le copier coller ayant déja été réalisé je n'ai pas utilisé la méthode

Code :

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

Application.EnableEvents = False

Pour régler mon proble de Numsoc, j'ai appliqué un numéro incrémenté pour tous les vides que je dois modifier au fur et a mesure.
Le problème est que je sélectionne, modifie le Numsoc, mais je ne peux modifier car il ne reconnait pas le numéro initial, du coup je crée un nouvel enregistrement et supprime l'ancien.

Merci en tout cas pour toutes tes explications.

Bonne soirée a toi

Assistance et correction sur Macro

Macros et VBA Excel

Discussions similaires

Partager

Partager