[XL-2003] Optimisation de code

[nico77ssx]

Salut,
Bon j'ai réalisé une BDD avec des macros pour la saisie et la recherche.
Etant débutant en vba, mon code est assez, comment dire, moche. Un peu frankesteiniser dans tous les sens. Maintenant j'essaye de l'optimiser mais comme j'ai des variables déclarées un peu n'importe ou, je fais planter mes macros.
Du coup, quelque qu'un se sent il capable d'étudier le code et l'optimiser ?
Le fichier fonctionne niquel mais c'est surtout pour avoir un truc "propre"

[Qwazerty]

Salut

Le mieux serait de poster ton code ici pour que l'on puisse travailler dessus.

++
Qwaz

[nico77ssx]

Euh c'est pas plus simple d'envoyer le fichier ( en épurant la BDD car elle contient 300 entrées) ? Parce que sinon, il va falloir que j'explique tout.

[Qwazerty]

Envoyé par nico77ssx

Parce que sinon, il va falloir que j'explique tout.

Salut

Ah ben oui c'est dramatique, c'est dur la vie, parfois il faut faire des efforts pour avoir un peu d'aide

En plaçant déjà ton code, on devrait pouvoir faire des simplifications si besoin même si on a pas le fichier. Explique en gros ce que fait le code déjà et place le ici (avec les balises code). Si c'est vraiment trop touffu ou compliquer on quémandera le fichier

Pour info, le but de placer le code directement permet à tous le monde d'y mettre son grain de sel et d'apporter des idées, tu aura ainsi bien plus de chance de trouver une aide qui correspond à ton besoin.

++
Qwaz

[nico77ssx]

Bon ok
Tu l'auras voulu lol
C'est un fichier client avec numéro de carte d'abonnement pour du transport en commun. Certains clients utilisent les lignes régulières (LR) ou des services spéciaux (SP), mais je n'entre pas dans les détails.

Alors le classeur comporte 3 feuilles: creation, bdd, choix
La première contient juste un bouton qui affiche l'userform, la seconde contient la base, la première ligne étant la 8 et les colonnes allant de B à Y. La dernière contient les valeurs pour les combobox

L'userform contient plein de champs, dont certains obligatoires.
On peut effectuer, via 3 boutons, 3 type de recherche
- par le nom
- par le numéro de carte (6 lettres et chiffres)
- par le secteur (de 1 à 4 ) ou le lot (4 lettres et chiffres)
Le résultat de la recherche s'affiche dans l'userform (si il n'y a qu'une réponse) ou dans une listbox. On double clique alors pour afficher la ligne qu'on veut dans l'userform.

Deux possibilités: on crée un nouvel adhérent ou on en modifie un ( adresse, téléphone, etc...)
On peut aussi renouveler la carte en cas de perte, auquel cas on change juste le numéro de carte. On cochera la case "renouv"

On valide, et la macro:
-demande confirmation
- vérifie les champs obligatoires
-copie les données dans la BDD
- ouvre un .doc selon le type de client (LR ou SP) + effectue un publipostage + imprime et enregistre le .doc au nom du client.
-ensuite elle "formate" les bordures, les alignements dans la BDD

Voilà ! J'aurais des choses à ajouter, comme la possibilité d'envoi de mail au lieu d'un courrier, un autre type de courrier à "publiposter" en cas de renouvellement.
L'impression fonctionne sur l'imprimante par défaut mais pas moyen d'envoyer sur l'autre imprimante, sur le bac 2, pour imprimer sur du papier entête. C'est pour ca que j'ai mis la partie impression, publi en deux grandes lignes commentaires, car j'ai pas encore trouver le truc

Idéalement, je souhaiterais bien différencier les parties proprement, exemple: un module "recherche", un module "impression", etc...

Là j'ai du code sur l'userform, dans un module et dans le "workbook" pour se mettre sur la page creation dès l'ouverture.

Alors le code de l'userform, puis le code du module

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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
 
Dim lig As Integer, modif As Integer, renouvx As Integer, NDF As String, NDF2 As String, DNSS As String
 
 
 
Private Sub BOUTONCREATION_Click()
' on va créer ou modifier une fiche
 
    If MsgBox("Avez-vous rempli tous les champs spécifiques à votre service ?", vbQuestion + vbYesNo, "ATTENTION") = vbYes Then
    ' LA REPONSE EST "OUI"
 
 
 
                       ' CHAMPS OBLIGATOIRES REMPLIS ?
                        If Me.NOM.Text = "" Then
 
                            MsgBox "Vous devez entrer un nom."
                            Me.NOM.SetFocus
                            Exit Sub
                        End If
                        If Me.PRENOM.Text = "" Then
 
                            MsgBox "Vous devez entrer un prénom."
                            Me.PRENOM.SetFocus
                            Exit Sub
                        End If
                        If Me.civil.Text = "" Then
                            MsgBox "Oubli de civilité"
                            Me.civil.SetFocus
                            Exit Sub
                        End If
                        If Me.JOURNSS.Text = "" Then
 
                            MsgBox "Date de naissance incomplète."
                            Me.JOURNSS.SetFocus
                            Exit Sub
                        End If
                        If Me.MOISNSS.Text = "" Then
 
                            MsgBox "Date de naissance incomplète."
                            Me.MOISNSS.SetFocus
                            Exit Sub
                        End If
                        If Me.ANNEENSS.Text = "" Then
 
                            MsgBox "Date de naissance incomplète."
                            Me.ANNEENSS.SetFocus
                            Exit Sub
                        End If
                        If Me.STATUT.Text = "" Then
 
                            MsgBox "Il faut un statut."
                            Me.STATUT.SetFocus
                            Exit Sub
                        End If
                        If Me.ADRESSE.Text = "" Then
 
                            MsgBox "Adresse incomplète."
                            Me.ADRESSE.SetFocus
                            Exit Sub
                        End If
                        If Me.COMMUNE.Text = "" Then
 
                            MsgBox "Commune de résidence non renseignée."
                            Me.COMMUNE.SetFocus
                            Exit Sub
                        End If
                        If Me.TELFIXE.Text = "" And Me.TELMOB = "" Then
 
                            MsgBox "Au moins un téléphone obligatoire."
                            Me.TELFIXE.SetFocus
                            Exit Sub
                        End If
                        If Me.LR.Value = False And Me.CSS.Value = False Then
                            MsgBox "Il faut choisir LR ou CSS"
                            Exit Sub
                        End If
                        If Me.numcarte.Text = "" Then
 
                            MsgBox "Numéro de carte non renseignée."
                            Me.numcarte.SetFocus
                            Exit Sub
                        End If
 
'ok tout est rempli on continue
                        ' Conversion du nom et prénom en NOMPRPRE
                        Nomconverti = Application.WorksheetFunction.Proper(Me.NOM.Text)
                        prenomconverti = Application.WorksheetFunction.Proper(Me.PRENOM.Text)
                        ' Selection derniere ligne du tableau si création ou de la ligne si modif
                        If modif = 0 Then
                        ' c'est une nouvelle fiche
                            Sheets("BDD").Select
 
                            valeur = Range("B8").Value
                                If valeur = "" Then
                                Range("B8").Select
                                Else
                                Range("B7").Select
                                Selection.End(xlDown).Select
                                ligneactive = ActiveCell.Row
                                Range("B" & ligneactive + 1).Select
                                End If
                            ligneactive = ActiveCell.Row
                            ' collage date de création dev la fiche et délivrance de la carte identiques puisque nouvelle fiche
                            Range("B" & ligneactive).Select
                            Selection.NumberFormat = "DD/MM/YYYY"
                            Range("B" & ligneactive).Value = Now
                            Range("q" & ligneactive).Select
                            Selection.NumberFormat = "DD/MM/YYYY"
                            Range("q" & ligneactive).Value = Now
 
 
                        Else
                            ' sinon c'est une modif éventuelle, la ligne active est celle renvoyée par une des trois recherches
                            ligneactive = lig
 
                        End If
                        ' Collage des donnees dans la BDD que ce soit création ou modification
 
                        secval = Val(secteur)
                        If secval = 0 Then secval = ""
 
                        Range("u" & ligneactive).Value = secval
 
                        Range("v" & ligneactive).Value = lot
                        Range("w" & ligneactive).Value = classe
                        Range("C" & ligneactive).Value = civil
                        Range("d" & ligneactive).Value = Nomconverti
                        Range("e" & ligneactive).Value = prenomconverti
                        Range("f" & ligneactive).Value = STATUT
                        DNSS = JOURNSS & "/" & MOISNSS & "/" & ANNEENSS
                        Range("g" & ligneactive).Value = DNSS
                        Range("h" & ligneactive).Value = TELFIXE
                        Range("i" & ligneactive).Value = TELMOB
                        Range("h" & ligneactive & ":i" & ligneactive).Select
                        Selection.NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
                        Range("j" & ligneactive).Value = mel
                        Range("k" & ligneactive).Value = ADRESSE
                        Range("l" & ligneactive).Value = COMMUNE
                        Range("m" & ligneactive).Value = montee
                        Range("n" & ligneactive).Value = ets
                        Range("o" & ligneactive).Value = destiville
                        Range("p" & ligneactive).Value = numcarte
 
                        If renouv = True Then
                            'si on a coché la case renouv (ellement), on délivre un nouvelle carte donc on change seulement la date de délivrance
                            Range("q" & ligneactive).Select
                            Selection.NumberFormat = "DD/MM/YYYY"
                            Range("q" & ligneactive).Value = Now
                            'on compte le nombre de renouvellement
                            renouvx = renouvx + 1
                        End If
 
                        Range("r" & ligneactive).Value = renouvx
 
                        Range("s" & ligneactive).Value = Li1
                        Range("t" & ligneactive).Value = Li2
                        Range("u" & ligneactive).Value = Li3
                        Range("y" & ligneactive).Value = anneesco
 
 
 
 
 
 
 
 
'----------------------------------ouverture word------------------------------------------
 
' si c'est un renouvellement=choix courrier1, si c'est une création LR=choix courrier2 si c'est une création SP=courrier3
' si c'est aucun des trois, juste une modif de l'adresse ou autre, on imprime rien et on envoie rien
                    ADRESSE1 = CStr(ADRESSE)
                    COMMUNE1 = CStr(COMMUNE)
                    civil1 = CStr(civil)
                    createur1 = CStr(createur)
 
 
 
                    Dim WordApp As Word.Application
                    Dim WordDoc As Word.Document
 
 
                        NDF2 = "s:\tests\" & Nomconverti & " " & prenomconverti & ".doc"
 
                        On Error Resume Next
                        Set WordApp = CreateObject("Word.Application")
                        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
 
                        With WordApp
                            .Visible = True
                        End With
                        With WordApp
                            .Selection.Goto what:=wdGoToBookmark, Name:="adresse"
                            .Selection.TypeText Text:=ADRESSE1
                        End With
                        With WordApp
                            .Selection.Goto what:=wdGoToBookmark, Name:="nomprenom"
                            .Selection.TypeText Text:=Nomconverti & " " & prenomconverti
                        End With
                        With WordApp
                            .Selection.Goto what:=wdGoToBookmark, Name:="commune"
                            .Selection.TypeText Text:=COMMUNE1
                        End With
                        With WordApp
                            .Selection.Goto what:=wdGoToBookmark, Name:="civilite"
                            .Selection.TypeText Text:=civil1
                        End With
                        With WordApp
                            .Selection.Goto what:=wdGoToBookmark, Name:="civilite2"
                            .Selection.TypeText Text:=civil1
                        End With
                        With WordApp
                            .Selection.Goto what:=wdGoToBookmark, Name:="civilite3"
                            .Selection.TypeText Text:=civil1
                        End With
                        With WordApp
                            .Selection.Goto what:=wdGoToBookmark, Name:="createur"
                            .Selection.TypeText Text:=createur1
                        End With
                    Dim ImprCour As String
                    Dim Impr2 As String
                    ImprCour = Application.ActivePrinter
                    MsgBox ImprCour
                    Impr2 = "\\srv-imp\MU132703 sur Ne04:"
                    Application.ActivePrinter = Impr2
                    MsgBox Application.ActivePrinter
                    'ActiveDocument.PrintOut
                    Application.ActivePrinter = ImprCour
'imprimer tout de suite ?
 
 
    'scurrentprinter = ActivePrinter 'Save the current printer
 
'If MsgBox("Imprimer ?", vbQuestion + vbYesNo, "ATTENTION") = vbYes Then
 
    'stray = Options.DefaultTray 'Save the current tray
    'With WordApp
    'ActivePrinter = "\\srv-imp\MU132703"
    'Application.PrintOut Filename:="", Range:=wdPrintAllDocument, Item:= _
        'wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
        'ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
        'False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        'PrintZoomPaperHeight:=0
    'End With
    'ActivePrinter = scurrentprinter 'Restore the original printer
    'Options.DefaultTray = stray 'Restore the original tray
'End If
 
                        WordDoc.Application.ActiveDocument.SaveAs NDF2
                        WordApp.Application.Quit
                        Set WordDoc = Nothing
                        Set WordApp = Nothing
 
 
'----------------------------------fermeture de word---------------------------------------------------
 
                        ' mise en forme conditionnelle des données dans la BDD
                        Range("B" & ligneactive & ":y" & ligneactive).Select
                        Selection.FormatConditions.Delete
                        Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
                            "=MOD(LIGNE();2)"
                        Selection.FormatConditions(1).Interior.ColorIndex = 37
                        ' mise en forme bordures
                        With Range("p" & ligneactive & ":y" & ligneactive)
                        .HorizontalAlignment = xlCenter
                        End With
                        With Range("g" & ligneactive & ":i" & ligneactive)
                        .HorizontalAlignment = xlCenter
                        End With
                        Range("b" & ligneactive & ":y" & ligneactive).Select
                        With Selection.Borders(xlEdgeLeft)
                            .LineStyle = xlContinuous
                            .Weight = xlMedium
                            .ColorIndex = xlAutomatic
                        End With
                        With Selection.Borders(xlEdgeTop)
                            .LineStyle = xlContinuous
                            .Weight = xlThin
                            .ColorIndex = xlAutomatic
                        End With
                        With Selection.Borders(xlEdgeBottom)
                            .LineStyle = xlContinuous
                            .Weight = xlThin
                            .ColorIndex = xlAutomatic
                        End With
                        With Selection.Borders(xlEdgeRight)
                            .LineStyle = xlContinuous
                            .Weight = xlMedium
                            .ColorIndex = xlAutomatic
                        End With
                        With Selection.Borders(xlInsideVertical)
                            .LineStyle = xlContinuous
                            .Weight = xlHairline
                            .ColorIndex = xlAutomatic
                        End With
 
                        ' On décharge le formulaire et on affiche le nombre de renouvellements si renouv cochée
                             If renouv = True Then MsgBox ("carte renouvellé" & renouvx & " fois")
 
 
                        Unload Me
Else
    Exit Sub
End If
End Sub
 
Private Sub BOUTONRECHERCHER_Click()
' rechercher nom
Dim L1 As Integer, L2 As Integer, ltxt0 As Integer
Dim i As Integer, txt0 As String, txt1 As String
 
'effacer la listbox
ListBox1.Clear
'lire le champ nom
txt0 = NOM.Text
'longueur de la chaine à comparer
ltxt0 = Len(txt0)
If ltxt0 = 0 Then Exit Sub
 
Sheets("BDD").Select
 
'la dernière ligne du taleau
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
'revient en haut du tableau
Range("F8").Select
'les noms sont dans la colonne 3
 
For i = 8 To L2
txt1 = Cells(i, 4).Text
'comparer en majuscules avec le nom cherché
If UCase(Left(txt1, ltxt0)) = UCase(txt0) Then
 
  txtprenom = Cells(i, 5).Text
  txtdatenss = Cells(i, 7).Text
'si c'est bon on l'ajoute a la ListBox
'et en préfixe la valeur de la ligne ou il se trouve
ListBox1.AddItem (Str(i) & " : " & txt1 & " " & txtprenom & " " & txtdatenss)
End If
Next
 
'on regarde le contenu de ListBox
Select Case ListBox1.ListCount
Case 0 ' vide
MsgBox "Rien trouvé"
 
Case 1 ' un seul correspond
 
txt1 = ListBox1.List(0)
'recuperer la n° de la ligne ou se trouve le nom dans le tableau
 
i = Val(txt1)
lig = i
'lire les valeur de la ligne du taleau (Nom,Prenom...)
 
    'si les champs secteur et lot sont remplis alors la case sp (css) est cochée
    'sinon c'est la case LR
    If Range("v" & lig).Value <> "" And Range("w" & lig).Value <> "" Then
    Me.CSS.Value = True
    Else: Me.LR.Value = True
    End If
 
   secteur = Range("v" & lig).Value
    lot = Range("w" & lig).Value
    classe = Range("x" & lig).Value
    NOM = Range("d" & lig).Value
    PRENOM = Range("e" & lig).Value
    STATUT = Range("f" & lig).Value
    varnss = Range("g" & lig).Value
    civil = Range("C" & lig).Value
    JOURNSS = Left(varnss, 2)
    ANNEENSS = Right(varnss, 4)
    MOISNSS = Mid(varnss, 4, 2)
    TELFIXE = Range("h" & lig).Value
    TELMOB = Range("i" & lig).Value
    mel = Range("ij" & lig).Value
    ADRESSE = Range("k" & lig).Value
    COMMUNE = Range("l" & lig).Value
    montee = Range("m" & lig).Value
    ets = Range("n" & lig).Value
    destiville = Range("o" & lig).Value
    numcarte = Range("p" & lig).Value
 
    renouvx = Range("r" & lig).Value
 
 Li1 = Range("s" & lig).Value
  Li2 = Range("t" & lig).Value
   Li3 = Range("u" & lig).Value
    anneesco = Range("y" & lig).Value
    modif = 1
    ligmodif = lig
Case Else 'sinon montre la listbox pour faire un choix
ListBox1.Visible = True
End Select
End Sub
 
Private Sub boutonquit_Click()
Sheets("creation").Select
Unload Me
End Sub
 
Private Sub CommandButton2_Click()
' recherche coupon
 
Dim L1 As Integer, L2 As Integer, ltxt0 As Integer
Dim i As Integer, txt0 As String, txt1 As String
 
 
ListBox2.Clear
txt0 = numcoupon.Text
ltxt0 = Len(txt0)
If ltxt0 = 0 Then Exit Sub
Sheets("BDD").Select
L1 = 8
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
Range("F8").Select
For i = L1 To L2
txt1 = Cells(i, 16).Text
If UCase(Left(txt1, ltxt0)) = UCase(txt0) Then
 
  txtprenom = Cells(i, 5).Text
  txtnom = Cells(i, 4).Text
  txtdatenss = Cells(i, 6).Text
ListBox2.AddItem (Str(i) & " : " & txt1 & " " & txtprenom & " " & txtdatenss)
End If
Next
 
'on regarde le contenu de ListBox2
Select Case ListBox2.ListCount
Case 0 ' vide
MsgBox "Rien trouvé"
 
Case 1 ' un seul correspond
'lire l'enregistrement 0
txt1 = ListBox2.List(0)
'recuperer la n° de la ligne ou se trouve le nom dans le tableau
 
i = Val(txt1)
lig = i
'lire les valeur de la ligne du taleau (Nom,Prenom...)
    If Range("v" & lig).Value <> "" And Range("w" & lig).Value <> "" Then
    Me.CSS.Value = True
    Else: Me.LR.Value = True
    End If
   secteur = Range("v" & lig).Value
    lot = Range("w" & lig).Value
    classe = Range("x" & lig).Value
    civil = Range("C" & lig).Value
    NOM = Range("d" & lig).Value
    PRENOM = Range("e" & lig).Value
    STATUT = Range("f" & lig).Value
    varnss = Range("g" & lig).Value
 
    JOURNSS = Left(varnss, 2)
    ANNEENSS = Right(varnss, 4)
    MOISNSS = Mid(varnss, 4, 2)
    TELFIXE = Range("h" & lig).Value
    TELMOB = Range("i" & lig).Value
    mel = Range("j" & lig).Value
    ADRESSE = Range("k" & lig).Value
    COMMUNE = Range("l" & lig).Value
    montee = Range("m" & lig).Value
    ets = Range("n" & lig).Value
    destiville = Range("o" & lig).Value
    numcarte = Range("p" & lig).Value
 
    renouvx = Range("r" & lig).Value
 
 Li1 = Range("s" & lig).Value
  Li2 = Range("t" & lig).Value
   Li3 = Range("u" & lig).Value
    anneesco = Range("y" & lig).Value
    modif = 1
    ligmodif = lig
Case Else 'sinom montre la listbox pour faire un choix
ListBox2.Visible = True
End Select
End Sub
 
Private Sub CommandButton3_Click()
' generer liste par recherche du secteur ou du lot
Dim i As Integer
Sheets("bdd").Select
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
Range("F8").Select
listsco.Clear
sec1 = Val(secteur)
lot1 = UCase(lot.Text)
   If sec1 > 0 And lot1 = "" Then
        lot.Value = ""
        For i = 8 To L2
        sec1 = Cells(i, 22).Value
 
        If sec1 = Val(secteur) Then
        lenom = Cells(i, 4).Value
        leprenom = Cells(i, 5).Value
        txtdatenss = Cells(i, 7).Value
        lot1 = Cells(i, 23).Value
        listsco.AddItem (Str(i) & " : Sect " & sec1 & " " & lot1 & " " & lenom & " " & leprenom & " " & txtdatenss)
        End If
        Next
        secteur.Value = ""
 
    ElseIf lot1 <> "" And sec1 = 0 Then
    secteur.Value = ""
        For i = 8 To L2
        If lot1 = UCase(Cells(i, 23).Value) Then
        sec1 = Cells(i, 22).Value
        lenom = Cells(i, 4).Value
        leprenom = Cells(i, 5).Value
        txtdatenss = Cells(i, 7).Value
        listsco.AddItem (Str(i) & " : Sect " & sec1 & " " & lot1 & " " & lenom & " " & leprenom & " " & txtdatenss)
        End If
        Next
        lot.Value = ""
    ElseIf lot1 = "" And sec1 = 0 Then
 
        For i = 8 To L2
        sec1 = Cells(i, 22).Value
        lot1 = Cells(i, 23).Value
        lenom = Cells(i, 4).Value
        leprenom = Cells(i, 5).Value
        txtdatenss = Cells(i, 7).Value
        If Cells(i, 22).Value > 0 Then
 
        listsco.AddItem (Str(i) & " : Sect " & sec1 & " " & lot1 & " " & lenom & " " & leprenom & " " & txtdatenss)
        End If
        Next
End If
 
End Sub
 
 
 
Private Sub CSS_Click()
NDF = "s:\tests\lettre circuits spéciaux sco.doc"
End Sub
 
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'Choix pour Liste retournée par recherche d'un nom
Dim ind As Integer
Dim txt As String
'indice du choix
ind = ListBox1.ListIndex
txt = ListBox1.List(ind)
'recuperer la n° de la ligne ou se trouve le nom dans le tableau
lig = Val(txt)
'faire disparaire la listbox
ListBox1.Visible = False
'lire les valeur de la ligne du taleau (Nom,Prenom...)
 
        If Range("v" & lig).Value <> "" And Range("w" & lig).Value <> "" Then
    Me.CSS.Value = True
    Else: Me.LR.Value = True
    End If
    secteur = Range("v" & lig).Value
    lot = Range("w" & lig).Value
    classe = Range("x" & lig).Value
    civil = Range("C" & lig).Value
    NOM = Range("d" & lig).Value
    PRENOM = Range("e" & lig).Value
    STATUT = Range("f" & lig).Value
    varnss = Range("g" & lig).Value
 
    JOURNSS = Left(varnss, 2)
    ANNEENSS = Right(varnss, 4)
    MOISNSS = Mid(varnss, 4, 2)
    TELFIXE = Range("h" & lig).Value
    TELMOB = Range("i" & lig).Value
    mel = Range("j" & lig).Value
    ADRESSE = Range("k" & lig).Value
    COMMUNE = Range("l" & lig).Value
    montee = Range("m" & lig).Value
    ets = Range("n" & lig).Value
    destiville = Range("o" & lig).Value
    numcarte = Range("p" & lig).Value
 
    renouvx = Range("r" & lig).Value
 Li1 = Range("s" & lig).Value
  Li2 = Range("t" & lig).Value
   Li3 = Range("u" & lig).Value
    anneesco = Range("y" & lig).Value
    modif = 1
    ligmodif = lig
 
End Sub
 
Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
' choix pour liste par recherche du numéro de carte
Dim ind As Integer
Dim txt As String
'indice du choix
ind = ListBox2.ListIndex
txt = ListBox2.List(ind)
'recuperer la n° de la ligne ou se trouve le nom dans le tableau
lig = Val(txt)
'faire disparaire la listbox
ListBox2.Visible = False
'lire les valeurs de la ligne du taleau (Nom,Prenom...)
 
        If Range("v" & lig).Value <> "" And Range("w" & lig).Value <> "" Then
    Me.CSS.Value = True
    Else: Me.LR.Value = True
    End If
    secteur = Range("v" & lig).Value
    lot = Range("w" & lig).Value
    classe = Range("x" & lig).Value
    civil = Range("C" & lig).Value
    NOM = Range("d" & lig).Value
    PRENOM = Range("e" & lig).Value
    STATUT = Range("f" & lig).Value
    varnss = Range("g" & lig).Value
 
    JOURNSS = Left(varnss, 2)
    ANNEENSS = Right(varnss, 4)
    MOISNSS = Mid(varnss, 4, 2)
    TELFIXE = Range("h" & lig).Value
    TELMOB = Range("i" & lig).Value
    mel = Range("j" & lig).Value
    ADRESSE = Range("k" & lig).Value
    COMMUNE = Range("l" & lig).Value
    montee = Range("m" & lig).Value
    ets = Range("n" & lig).Value
    destiville = Range("o" & lig).Value
    numcarte = Range("p" & lig).Value
 
 
    renouvx = Range("r" & lig).Value
 Li1 = Range("s" & lig).Value
  Li2 = Range("t" & lig).Value
   Li3 = Range("u" & lig).Value
    anneesco = Range("y" & lig).Value
    modif = 1
    ligmodif = lig
 
 
End Sub
 
Private Sub listsco_dblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim ind As Integer
Dim txt As String
'indice du choix
ind = listsco.ListIndex
'texte choisi
txt = listsco.List(ind)
'recuperer la n° de la ligne ou se trouve le nom dans le tableau
 
lig = Val(txt)
'faire disparaire la listbox
ListBox1.Visible = False
'lire les valeur de la ligne du taleau (Nom,Prenom...)
 
 
 
'Range("B" & ligneactive).Select
    'Selection.NumberFormat = "DD/MM/YYYY"
    'Range("B" & i).Value = Now
        If Range("v" & lig).Value <> "" And Range("w" & lig).Value <> "" Then
    Me.CSS.Value = True
    Else: Me.LR.Value = True
    End If
    secteur = Range("v" & lig).Value
    lot = Range("w" & lig).Value
    classe = Range("x" & lig).Value
    civil = Range("C" & lig).Value
    NOM = Range("d" & lig).Value
    PRENOM = Range("e" & lig).Value
    STATUT = Range("f" & lig).Value
    varnss = Range("g" & lig).Value
 
    JOURNSS = Left(varnss, 2)
    ANNEENSS = Right(varnss, 4)
    MOISNSS = Mid(varnss, 4, 2)
    TELFIXE = Range("h" & lig).Value
    TELMOB = Range("i" & lig).Value
    mel = Range("j" & lig).Value
    ADRESSE = Range("k" & lig).Value
    COMMUNE = Range("l" & lig).Value
    montee = Range("m" & lig).Value
    ets = Range("n" & lig).Value
    destiville = Range("o" & lig).Value
    numcarte = Range("p" & lig).Value
 
    renouvx = Range("r" & lig).Value
 Li1 = Range("s" & lig).Value
  Li2 = Range("t" & lig).Value
   Li3 = Range("u" & lig).Value
    anneesco = Range("y" & lig).Value
    modif = 1
    ligmodif = lig
End Sub
 
Private Sub LR_Click()
NDF = "s:\tests\lettre ligne reguliere.doc"
End Sub
 
Private Sub mel_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(LCase(Chr(KeyAscii)))
 
End Sub
 
Private Sub nom_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(LCase(Chr(KeyAscii)))
End Sub
 
Private Sub numcarte_keyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = Asc(UCase(Chr(KeyAscii)))
 
 
End Sub
 
Private Sub OptionButton1_Click()
MsgBox "oui"
End Sub
 
Private Sub Telfixe_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    Case Is < 48, Is > 57
        KeyAscii = 0
    End Select
End Sub
Private Sub Telmob_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    Case Is < 48, Is > 57
        KeyAscii = 0
    End Select
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub
 
Private Sub numcoupon_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
 
End Sub
 
Private Sub UserForm_Initialize()
 
With NOM
    .SetFocus
    .SelStart = 0
 
End With
End Sub

Et le simple code du module

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
 
 
Sub bouton27_QuandClic()
 
UserForm2.Show
 
 
modif = 0
Dim lig As Integer
 
 
 
End Sub

[Qwazerty]

Salut

Voila quelques remarques, tiens en compte dans le reste de ton code et poste le résultat

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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
Option Explicit
 
'Essai de toujours mettre au moins une majuscule dans tes noms de variables, ça permet de controler l'orthographe lors de la frappe du code
Dim Lig As Integer, Modif As Integer, RenouvX As Integer, NDF As String, NDF2 As String, DNSS As String
 
 
 
Private Sub BOUTONCREATION_Click()
'Il serait préférable de déclarer tes variables
Dim NomConverti As String
'....
 
'Utilise les indentations avec parcimonie, inutile de décaler le code de 5 tabulations
 
' on va créer ou modifier une fiche
    If MsgBox("Avez-vous rempli tous les champs spécifiques à votre service ?", vbQuestion + vbYesNo, "ATTENTION") = vbYes Then
    ' LA REPONSE EST "OUI"
 
        ' CHAMPS OBLIGATOIRES REMPLIS ?
        If Me.NOM.Text = "" Then
 
            MsgBox "Vous devez entrer un nom."
            Me.NOM.SetFocus
            Exit Sub
        End If
        If Me.PRENOM.Text = "" Then
 
            MsgBox "Vous devez entrer un prénom."
            Me.PRENOM.SetFocus
            Exit Sub
        End If
        If Me.civil.Text = "" Then
            MsgBox "Oubli de civilité"
            Me.civil.SetFocus
            Exit Sub
        End If
        If Me.JOURNSS.Text = "" Then
 
            MsgBox "Date de naissance incomplète."
            Me.JOURNSS.SetFocus
            Exit Sub
        End If
        If Me.MOISNSS.Text = "" Then
 
            MsgBox "Date de naissance incomplète."
            Me.MOISNSS.SetFocus
            Exit Sub
        End If
        If Me.ANNEENSS.Text = "" Then
 
            MsgBox "Date de naissance incomplète."
            Me.ANNEENSS.SetFocus
            Exit Sub
        End If
        If Me.STATUT.Text = "" Then
 
            MsgBox "Il faut un statut."
            Me.STATUT.SetFocus
            Exit Sub
        End If
        If Me.ADRESSE.Text = "" Then
 
            MsgBox "Adresse incomplète."
            Me.ADRESSE.SetFocus
            Exit Sub
        End If
        If Me.COMMUNE.Text = "" Then
 
            MsgBox "Commune de résidence non renseignée."
            Me.COMMUNE.SetFocus
            Exit Sub
        End If
        If Me.TELFIXE.Text = "" And Me.TELMOB = "" Then
 
            MsgBox "Au moins un téléphone obligatoire."
            Me.TELFIXE.SetFocus
            Exit Sub
        End If
        If Me.LR.Value = False And Me.CSS.Value = False Then
            MsgBox "Il faut choisir LR ou CSS"
            Exit Sub
        End If
        If Me.numcarte.Text = "" Then
 
            MsgBox "Numéro de carte non renseignée."
            Me.numcarte.SetFocus
            Exit Sub
        End If
 
        'ok tout est rempli on continue
        ' Conversion du nom et prénom en NOMPRPRE
        NomConverti = Application.WorksheetFunction.Proper(Me.NOM.Text)
        prenomconverti = Application.WorksheetFunction.Proper(Me.PRENOM.Text)
        ' Selection derniere ligne du tableau si création ou de la ligne si modif
        With ThisWorkbook.Sheets("BDD")
            If Modif = 0 Then
            ' c'est une nouvelle fiche
                'Inutile de selectionner la feuille, il suffit de la pointer c'est tout
                'Il est mieux de préciser le classeur (ici ThisWorkbook)
                'Sheets("BDD").Select
                'Il est en générale préférable de partir du bas et de remonter vers le haut pour trouver la dérniere ligne vide
                'Comme ça pas besoin de s'embeter avec l'entête, au contraire, elle nous aide
                With .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                    ' collage date de création dev la fiche et délivrance de la carte identiques puisque nouvelle fiche
                    .NumberFormat = "DD/MM/YYYY"
                    .Value = Now
                    .Offset(0, 15).NumberFormat = "DD/MM/YYYY"
                    .Offset(0, 15).Value = Now
                    ligneactive = .Row
                End With
 
            Else
                ' sinon c'est une modif éventuelle, la ligne active est celle renvoyée par une des trois recherches
                ligneactive = Lig
 
            End If
 
            ' Collage des donnees dans la BDD que ce soit création ou modification
 
            secval = Val(secteur)
            If secval = 0 Then secval = ""
 
            .Range("u" & ligneactive).Value = secval
 
            .Range("v" & ligneactive).Value = lot
            .Range("w" & ligneactive).Value = classe
            .Range("C" & ligneactive).Value = civil
            .Range("d" & ligneactive).Value = NomConverti
            .Range("e" & ligneactive).Value = prenomconverti
            .Range("f" & ligneactive).Value = STATUT
            DNSS = JOURNSS & "/" & MOISNSS & "/" & ANNEENSS
            .Range("g" & ligneactive).Value = DNSS
            .Range("h" & ligneactive).Value = TELFIXE
            .Range("i" & ligneactive).Value = TELMOB
            'Pas besoin du select
            .Range("h" & ligneactive & ":i" & ligneactive).NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
            .Range("j" & ligneactive).Value = mel
            .Range("k" & ligneactive).Value = ADRESSE
            .Range("l" & ligneactive).Value = COMMUNE
            .Range("m" & ligneactive).Value = montee
            .Range("n" & ligneactive).Value = ets
            .Range("o" & ligneactive).Value = destiville
            .Range("p" & ligneactive).Value = numcarte
 
            If renouv = True Then
                'si on a coché la case renouv (ellement), on délivre un nouvelle carte donc on change seulement la date de délivrance
                .Range("q" & ligneactive).NumberFormat = "DD/MM/YYYY"
                .Range("q" & ligneactive).Value = Now
                'on compte le nombre de renouvellement
                RenouvX = RenouvX + 1
            End If
 
            .Range("r" & ligneactive).Value = RenouvX
 
            .Range("s" & ligneactive).Value = Li1
            .Range("t" & ligneactive).Value = Li2
            .Range("u" & ligneactive).Value = Li3
            .Range("y" & ligneactive).Value = anneesco
 
 
 
 
'----------------------------------ouverture word------------------------------------------
 
' si c'est un renouvellement=choix courrier1, si c'est une création LR=choix courrier2 si c'est une création SP=courrier3
' si c'est aucun des trois, juste une modif de l'adresse ou autre, on imprime rien et on envoie rien
            ADRESSE1 = CStr(ADRESSE)
            COMMUNE1 = CStr(COMMUNE)
            civil1 = CStr(civil)
            createur1 = CStr(createur)
 
 
'Un conseil, place toutes tes déclarations en début de procédure c'est plus claire
            Dim WordApp As Word.Application
            Dim WordDoc As Word.Document
 
 
            NDF2 = "s:\tests\" & NomConverti & " " & prenomconverti & ".doc"
 
            'Attention avec On Error Resume next, si tu as des erreur dans ton code, VBA ne te previent plus...
            'quel erreur avais-tu ?
            Set WordApp = CreateObject("Word.Application")
            'Je suppose que l'erreur venait de la ligne suivante, si le fichier n'était pas présent, dans ce cas il faut gérer ainsi
            On Error Resume Next
            Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
            On Error GoTo 0 'on réactive la géstion des erreurs
 
            'On vérifie que le fichier est présent dans la variable
            If WordDoc Is Nothing Then
                MsgBox "Fichier inexistant"
                '...
                'Ensuite tu gére comme tu veux
            Else
                'Le fichier est bien la
                'L'interêt de with c'est de pas avoir à retaper WordApp à chaque fois
                'De plus tu as défini WordDoc comme étant le document sur lequel tu travailles, autant l'utiliser,
                'ça évitera les problème si quelqu'un change le fichier actif dans la session de Word
                WordApp.Visible = True
                With WordDoc 'WordApp.Selection
                    .Goto what:=wdGoToBookmark, Name:="adresse"
                    .TypeText Text:=ADRESSE1
                    .Goto what:=wdGoToBookmark, Name:="nomprenom"
                    .TypeText Text:=NomConverti & " " & prenomconverti
                    .Goto what:=wdGoToBookmark, Name:="commune"
                    .TypeText Text:=COMMUNE1
                    .Goto what:=wdGoToBookmark, Name:="civilite"
                    .TypeText Text:=civil1
                    .Goto what:=wdGoToBookmark, Name:="civilite2"
                    .TypeText Text:=civil1
                    .Goto what:=wdGoToBookmark, Name:="civilite3"
                    .TypeText Text:=civil1
                    .Goto what:=wdGoToBookmark, Name:="createur"
                    .TypeText Text:=createur1
                End With
 
                'Déclaration en début de code
                Dim ImprCour As String
                Dim Impr2 As String
            'Je ne comprend pas ce que tu veux faire tu change 2 fois l'imprimante active?
                ImprCour = Application.ActivePrinter
                MsgBox ImprCour
                Impr2 = "\\srv-imp\MU132703 sur Ne04:"
                Application.ActivePrinter = Impr2
                MsgBox Application.ActivePrinter
                'ActiveDocument.PrintOut
                Application.ActivePrinter = ImprCour
'imprimer tout de suite ?
 
 
    'scurrentprinter = ActivePrinter 'Save the current printer
 
'If MsgBox("Imprimer ?", vbQuestion + vbYesNo, "ATTENTION") = vbYes Then
 
    'stray = Options.DefaultTray 'Save the current tray
    'With WordApp
    'ActivePrinter = "\\srv-imp\MU132703"
    'Application.PrintOut Filename:="", Range:=wdPrintAllDocument, Item:= _
        'wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
        'ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
        'False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        'PrintZoomPaperHeight:=0
    'End With
    'ActivePrinter = scurrentprinter 'Restore the original printer
    'Options.DefaultTray = stray 'Restore the original tray
'End If
 
                WordDoc.SaveAs 'NDF2Application.ActiveDocument. 'inutile, tu tournes en rond
                WordApp.Quit '.Application
                Set WordDoc = Nothing
                Set WordApp = Nothing
 
 
'----------------------------------fermeture de word---------------------------------------------------
 
                ' mise en forme bordures
                With .Range("p" & ligneactive & ":y" & ligneactive)
                    .HorizontalAlignment = xlCenter
                End With
                With Range("g" & ligneactive & ":i" & ligneactive)
                    .HorizontalAlignment = xlCenter
                End With
                ' mise en forme conditionnelle des données dans la BDD
                With .Range("B" & ligneactive & ":y" & ligneactive) '.Select
                    .FormatConditions.Delete
                    .FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(LIGNE();2)"
                    .FormatConditions(1).Interior.ColorIndex = 37
                    With .Borders(xlEdgeLeft)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlInsideVertical)
                        .LineStyle = xlContinuous
                        .Weight = xlHairline
                        .ColorIndex = xlAutomatic
                    End With
 
                ' On décharge le formulaire et on affiche le nombre de renouvellements si renouv cochée
                    If renouv = True Then MsgBox ("carte renouvellé" & RenouvX & " fois")
                End With
                'Place le après le End if si tu veux férmer ta UserForm y compris si le fihcier Doc n'est pas trouvé
                Unload Me
            End If
        End With
 
    Else
        Exit Sub
    End If
End Sub

et

Code :

1
2
3
4
5
6
7
Sub bouton27_QuandClic()
'Dim lig As Integer 'Inutile puisque Lig n'est pas utilisé dans cette procédure
 
    UserForm2.Show
    modif = 0
 
End Sub

Pour les questions de publipostage et autre, crée d'autres sujets pour chaque problème.

Et fait un effort avec l'indentation de ton code s'il te plait, ça ne demande aucune connaissance particulière, les gens du forum, moi y compris, voulons bien passer du temps pour remettre un peu d'ordre dans un code mais il serait sympathique de fournir un minimum d'effort dans la présentation du dit code, surtout quand il y en a un tel quantité. Merci.

++
Qwaz

[nico77ssx]

Chouette merci bien. C'est vrai que mes variables c'est le bordel

J'avais essayé de séparer le code en copiant certaines parties dans des modules mais j'avais des erreurs de "range". Je vais retenter avec ces belles variables bien déclarées.

Bon je travaille ça et je reviens ici
Merci

ah oui pour l'imprimante c'est parce que j'essayais de comprendre pourquoi le code marchait pas avec la deuxième imprimante, enfin bon, je verrais ca plus tard

[nico77ssx]

Voila, version épurée ! encore des trucs à améliorer je pense

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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
 
Option Explicit
Dim L2 As Integer
Dim i As Integer, Recherche As String, RetNom As String, RetPrenom As String, RetNumcarte As String, RetSec As String, RetLot As String
Dim ind As Integer, txt As String, RetDNSS As String, RetLig As String, VarDNSS As String, ltxt0 As Integer
Dim Lig As Integer, Modif As Integer, RenouvX As Integer, NDF As String, NDF2 As String, DNSS As String, NomConverti As String, PrenomConverti As String
 
Private Sub BOUTONCREATION_Click()
    If MsgBox("Avez-vous rempli tous les champs spécifiques à votre service ?", vbQuestion + vbYesNo, "ATTENTION") = vbYes Then
    ' LA REPONSE EST "OUI"
 
    ' CHAMPS OBLIGATOIRES REMPLIS ?
    If Me.NOM.Text = "" Then
        MsgBox "Vous devez entrer un nom."
        Me.NOM.SetFocus
        Exit Sub
    End If
    If Me.PRENOM.Text = "" Then
        MsgBox "Vous devez entrer un prénom."
        Me.PRENOM.SetFocus
        Exit Sub
    End If
    If Me.civil.Text = "" Then
        MsgBox "Oubli de civilité"
        Me.civil.SetFocus
        Exit Sub
    End If
    If Me.JOURNSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.JOURNSS.SetFocus
        Exit Sub
    End If
    If Me.MOISNSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.MOISNSS.SetFocus
        Exit Sub
    End If
    If Me.ANNEENSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.ANNEENSS.SetFocus
        Exit Sub
    End If
    If Me.STATUT.Text = "" Then
        MsgBox "Il faut un statut."
        Me.STATUT.SetFocus
        Exit Sub
    End If
    If Me.ADRESSE.Text = "" Then
        MsgBox "Adresse incomplète."
        Me.ADRESSE.SetFocus
        Exit Sub
    End If
    If Me.COMMUNE.Text = "" Then
        MsgBox "Commune de résidence non renseignée."
        Me.COMMUNE.SetFocus
        Exit Sub
    End If
    If Me.TELFIXE.Text = "" And Me.TELMOB = "" Then
        MsgBox "Au moins un téléphone obligatoire."
        Me.TELFIXE.SetFocus
        Exit Sub
    End If
    If Me.LR.Value = False And Me.CSS.Value = False Then
        MsgBox "Il faut choisir LR ou CSS"
        Exit Sub
    End If
        If Me.numcarte.Text = "" Then
        MsgBox "Numéro de carte non renseignée."
        Me.numcarte.SetFocus
        Exit Sub
    End If
 
' Conversion du nom et prénom en NOMPRPRE
    NomConverti = Application.WorksheetFunction.Proper(Me.NOM.Text)
    PrenomConverti = Application.WorksheetFunction.Proper(Me.PRENOM.Text)
' Selection derniere ligne ou modif
With ThisWorkbook.Sheets("BDD")
    If Modif = 0 Then
        With .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        ' collage date de création dev la fiche et délivrance de la carte identiques puisque nouvelle fiche
             .NumberFormat = "DD/MM/YYYY"
             .Value = Now
             .Offset(0, 15).NumberFormat = "DD/MM/YYYY"
             .Offset(0, 15).Value = Now
             Lig = .Row
        End With
    End If
 
            ' Collage des donnees dans la BDD que ce soit création ou modification
            Dim secval As String
            secval = Val(secteur)
            'If secval = 0 Then secval= ""
 
            .Range("u" & Lig).Value = secval
            .Range("v" & Lig).Value = lot
            .Range("w" & Lig).Value = classe
            .Range("C" & Lig).Value = civil
            .Range("d" & Lig).Value = NomConverti
            .Range("e" & Lig).Value = PrenomConverti
            .Range("f" & Lig).Value = STATUT
            DNSS = JOURNSS & "/" & MOISNSS & "/" & ANNEENSS
            .Range("g" & Lig).Value = DNSS
            .Range("h" & Lig).Value = TELFIXE
            .Range("i" & Lig).Value = TELMOB
            .Range("h" & Lig & ":i" & Lig).NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
            .Range("j" & Lig).Value = mel
            .Range("k" & Lig).Value = ADRESSE
            .Range("l" & Lig).Value = COMMUNE
            .Range("m" & Lig).Value = montee
            .Range("n" & Lig).Value = ets
            .Range("o" & Lig).Value = destiville
            .Range("p" & Lig).Value = numcarte
 
            If renouv = True Then
                'si on a coché la case renouv (ellement), on délivre un nouvelle carte donc on change seulement la date de délivrance
                .Range("q" & Lig).NumberFormat = "DD/MM/YYYY"
                .Range("q" & Lig).Value = Now
                'on compte le nombre de renouvellement
                RenouvX = RenouvX + 1
            End If
 
            .Range("r" & Lig).Value = RenouvX
            .Range("s" & Lig).Value = Li1
            .Range("t" & Lig).Value = Li2
            .Range("u" & Lig).Value = Li3
            .Range("y" & Lig).Value = anneesco
 
 ' procedure word
 
 ' mise en forme bordures
                With .Range("p" & Lig & ":y" & Lig)
                    .HorizontalAlignment = xlCenter
                End With
                With Range("g" & Lig & ":i" & Lig)
                    .HorizontalAlignment = xlCenter
                End With
                ' mise en forme conditionnelle des données dans la BDD
                With .Range("B" & Lig & ":y" & Lig) '.Select
                    .FormatConditions.Delete
                    .FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(LIGNE();2)"
                    .FormatConditions(1).Interior.ColorIndex = 37
                    With .Borders(xlEdgeLeft)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlMedium
                        .ColorIndex = xlAutomatic
                    End With
                    With .Borders(xlInsideVertical)
                        .LineStyle = xlContinuous
                        .Weight = xlHairline
                        .ColorIndex = xlAutomatic
                    End With
                End With
                ' On décharge le formulaire et on affiche le nombre de renouvellements si renouv cochée
                    If renouv = True Then MsgBox ("carte renouvellé" & RenouvX & " fois")
 
                'Place le après le End if si tu veux férmer ta UserForm y compris si le fihcier Doc n'est pas trouvé
                Unload Me
 
        End With
 
    Else
        Exit Sub
    End If
End Sub
 
Private Sub BT_SEARCH_NOM_Click()
 
ListBox_NOM.Clear
Recherche = NOM.Text
ltxt0 = Len(Recherche)
If ltxt0 = 0 Then Exit Sub
Sheets("BDD").Select
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
Range("F8").Select
For i = 8 To L2
RetNom = Cells(i, 4).Text
If UCase(Left(RetNom, ltxt0)) = UCase(Recherche) Then
  RetPrenom = Cells(i, 5).Text
  RetDNSS = Cells(i, 7).Text
ListBox_NOM.AddItem (Str(i) & " : " & RetNom & " " & RetPrenom & " " & RetDNSS)
End If
Next
 
'on regarde le contenu de ListBox1
Select Case ListBox_NOM.ListCount
    Case 0
        MsgBox "Rien trouvé"
 
    Case 1
    Lig = Val(ListBox_NOM.List(0))
        MoteurAffiche
 
    Case Else 'sinon montre la listbox pour faire un choix
    ListBox_NOM.Visible = True
End Select
 
End Sub
 
 
 
Private Sub BT_SEARCH_CARTE_Click()
' recherche coupon
 
ListBox_CARTE.Clear
Recherche = numcoupon.Text
ltxt0 = Len(Recherche)
If ltxt0 = 0 Then Exit Sub
Sheets("BDD").Select
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
Range("F8").Select
For i = 8 To L2
RetNumcarte = Cells(i, 16).Text
If Left(RetNumcarte, ltxt0) = Recherche Then
 
  RetPrenom = Cells(i, 5).Text
  RetNom = Cells(i, 4).Text
  RetDNSS = Cells(i, 6).Text
ListBox_CARTE.AddItem (Str(i) & " : " & RetNom & " " & RetPrenom & " " & RetDNSS & " " & RetNumcarte)
End If
Next
 
Select Case ListBox_CARTE.ListCount
    Case 0
    MsgBox "Rien trouvé"
 
    Case 1
    Lig = Val(ListBox_CARTE.List(0))
    MoteurAffiche
    ListBox_CARTE.Visible = False
 
    Case Else
    ListBox_CARTE.Visible = True
End Select
 
End Sub
 
Private Sub BT_SEARCH_SCO_Click()
' generer liste
 
Sheets("bdd").Select
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
Range("F8").Select
ListBox_SCO.Clear
'secteur=22 lot=23 nom=4 prenom=5 DNSS=7
 
   If secteur.Value <> "" Then
        Recherche = secteur.Value
        lot.Value = ""
        For i = 8 To L2
        RetSec = Cells(i, 22).Value
        If RetSec = Recherche Then
        RetNom = Cells(i, 4).Value
        RetPrenom = Cells(i, 5).Value
        RetDNSS = Cells(i, 7).Value
        RetLot = Cells(i, 23).Value
        ListBox_SCO.AddItem (Str(i) & " : Sect " & RetSec & " " & RetLot & " " & RetNom & " " & RetPrenom & " " & RetDNSS)
        End If
        Next
        secteur.Value = ""
 
End If
 
End Sub
 
Private Sub CSS_Click()
 
NDF = "s:\tests\lettre circuits spéciaux sco.doc"
 
End Sub
 
Private Sub ListBox_NOM_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
ind = ListBox_NOM.ListIndex
Lig = Val(ListBox_NOM.List(ind))
ListBox_NOM.Visible = False
MoteurAffiche
 
End Sub
 
Private Sub ListBox_CARTE_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
ind = ListBox_CARTE.ListIndex
Lig = Val(ListBox_CARTE.List(ind))
ListBox_CARTE.Visible = False
MoteurAffiche
 
End Sub
 
Private Sub ListBox_SCO_dblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
ind = ListBox_SCO.ListIndex
Lig = Val(ListBox_SCO.List(ind))
ListBox_SCO.Visible = True
MoteurAffiche
 
End Sub
 
Private Sub LR_Click()
NDF = "s:\tests\lettre ligne reguliere.doc"
End Sub
 
Private Sub mel_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(LCase(Chr(KeyAscii)))
 
End Sub
 
Private Sub nom_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(LCase(Chr(KeyAscii)))
End Sub
 
Private Sub numcarte_keyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = Asc(UCase(Chr(KeyAscii)))
 
 
End Sub
 
Private Sub OptionButton1_Click()
MsgBox "oui"
End Sub
 
Private Sub Telfixe_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    Case Is < 48, Is > 57
        KeyAscii = 0
    End Select
End Sub
 
Private Sub Telmob_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    Case Is < 48, Is > 57
        KeyAscii = 0
    End Select
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub
 
Private Sub numcoupon_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
 
End Sub
 
Private Sub UserForm_Initialize()
 
With NOM
    .SetFocus
    .SelStart = 0
 
End With
End Sub
 
Private Sub CommandButton1_Click()
Sheets("creation").Select
Unload Me
End Sub
 
Sub MoteurAffiche()
 
        If Range("v" & Lig).Value <> "" And Range("w" & Lig).Value <> "" Then
        Me.CSS.Value = True
        Else: Me.LR.Value = True
        End If
 
        civil = Range("C" & Lig).Value
        NOM = Range("d" & Lig).Value
        PRENOM = Range("e" & Lig).Value
        STATUT = Range("f" & Lig).Value
        VarDNSS = Range("g" & Lig).Value
        JOURNSS = Left(VarDNSS, 2)
        ANNEENSS = Right(VarDNSS, 4)
        MOISNSS = Mid(VarDNSS, 4, 2)
        TELFIXE = Range("h" & Lig).Value
        TELMOB = Range("i" & Lig).Value
        mel = Range("j" & Lig).Value
        ADRESSE = Range("k" & Lig).Value
        COMMUNE = Range("l" & Lig).Value
        montee = Range("m" & Lig).Value
        ets = Range("n" & Lig).Value
        destiville = Range("o" & Lig).Value
        numcarte = Range("p" & Lig).Value
        RenouvX = Range("r" & Lig).Value
        Li1 = Range("s" & Lig).Value
        Li2 = Range("t" & Lig).Value
        Li3 = Range("u" & Lig).Value
        secteur = Range("v" & Lig).Value
        lot = Range("w" & Lig).Value
        classe = Range("x" & Lig).Value
        anneesco = Range("y" & Lig).Value
        Modif = 1
End Sub

[Qwazerty]

Salut

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
180
181
182
183
184
185
186
Option Explicit
Dim L2 As Integer
Dim i As Integer, Recherche As String, RetNom As String, RetPrenom As String, RetNumcarte As String, RetSec As String, RetLot As String
Dim ind As Integer, txt As String, RetDNSS As String, RetLig As String, VarDNSS As String, ltxt0 As Integer
Dim Lig As Integer, Modif As Integer, RenouvX As Integer, NDF As String, NDF2 As String, DNSS As String, NomConverti As String, PrenomConverti As String
 
Private Sub BOUTONCREATION_Click()
'## Par principe on déclare toutes les variables en début de code
'## Je te conseil également de mettre une majuscule au moins dans chaque variables pour les repèrer plus vite dans le code (et pour voir les faute de frappe)
Dim SecVal As String
 
 
If MsgBox("Avez-vous rempli tous les champs spécifiques à votre service ?", vbQuestion + vbYesNo, "ATTENTION") = vbYes Then
    ' LA REPONSE EST "OUI"
'##Si c'etait pour moi, je testerais la totalité des champs un par un, je passerais en rouge le fond des champs mal renseignés
'##Puis si au moins une des données est mal renseigné, j'affiche un message demandant de remplire les champs en rouge.
'##Ca fait pas plus de boulot à codé et c'est plus élégant, enfin ça n'enguage que moi.
'##Par la suite, dans chaque champs, tu ajoute un bout de code qui passe le champs en blanc sur modification du contenu du dit champs
 
    ' CHAMPS OBLIGATOIRES REMPLIS ?
    If Me.NOM.Text = "" Then
        MsgBox "Vous devez entrer un nom."
        Me.NOM.SetFocus
        Exit Sub
    End If
    If Me.PRENOM.Text = "" Then
        MsgBox "Vous devez entrer un prénom."
        Me.PRENOM.SetFocus
        Exit Sub
    End If
    If Me.civil.Text = "" Then
        MsgBox "Oubli de civilité"
        Me.civil.SetFocus
        Exit Sub
    End If
    If Me.JOURNSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.JOURNSS.SetFocus
        Exit Sub
    End If
    If Me.MOISNSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.MOISNSS.SetFocus
        Exit Sub
    End If
    If Me.ANNEENSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.ANNEENSS.SetFocus
        Exit Sub
    End If
    If Me.STATUT.Text = "" Then
        MsgBox "Il faut un statut."
        Me.STATUT.SetFocus
        Exit Sub
    End If
    If Me.ADRESSE.Text = "" Then
        MsgBox "Adresse incomplète."
        Me.ADRESSE.SetFocus
        Exit Sub
    End If
    If Me.COMMUNE.Text = "" Then
        MsgBox "Commune de résidence non renseignée."
        Me.COMMUNE.SetFocus
        Exit Sub
    End If
    If Me.TELFIXE.Text = "" And Me.TELMOB = "" Then
        MsgBox "Au moins un téléphone obligatoire."
        Me.TELFIXE.SetFocus
        Exit Sub
    End If
    If Me.LR.Value = False And Me.CSS.Value = False Then
        MsgBox "Il faut choisir LR ou CSS"
        Exit Sub
    End If
        If Me.numcarte.Text = "" Then
        MsgBox "Numéro de carte non renseignée."
        Me.numcarte.SetFocus
        Exit Sub
    End If
 
' Conversion du nom et prénom en NOMPRPRE
    NomConverti = Application.WorksheetFunction.Proper(Me.NOM.Text)
    PrenomConverti = Application.WorksheetFunction.Proper(Me.PRENOM.Text)
' Selection derniere ligne ou modif
    With ThisWorkbook.Sheets("BDD")
        If Modif = 0 Then
            With .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
            ' collage date de création dev la fiche et délivrance de la carte identiques puisque nouvelle fiche
                 .NumberFormat = "DD/MM/YYYY"
                 .Value = Now
                 .Offset(0, 15).NumberFormat = "DD/MM/YYYY"
                 .Offset(0, 15).Value = Now
                 Lig = .Row
            End With
        End If
 
        ' Collage des donnees dans la BDD que ce soit création ou modification
        SecVal = Val(secteur)
        'If secval = 0 Then secval= ""
 
        .Range("u" & Lig).Value = SecVal
        .Range("v" & Lig).Value = lot
        .Range("w" & Lig).Value = classe
        .Range("C" & Lig).Value = civil
        .Range("d" & Lig).Value = NomConverti
        .Range("e" & Lig).Value = PrenomConverti
        .Range("f" & Lig).Value = STATUT
        DNSS = JOURNSS & "/" & MOISNSS & "/" & ANNEENSS
        .Range("g" & Lig).Value = DNSS
        .Range("h" & Lig).Value = TELFIXE
        .Range("i" & Lig).Value = TELMOB
        .Range("h" & Lig & ":i" & Lig).NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
        .Range("j" & Lig).Value = mel
        .Range("k" & Lig).Value = ADRESSE
        .Range("l" & Lig).Value = COMMUNE
        .Range("m" & Lig).Value = montee
        .Range("n" & Lig).Value = ets
        .Range("o" & Lig).Value = destiville
        .Range("p" & Lig).Value = numcarte
 
        If renouv = True Then
            'si on a coché la case renouv (ellement), on délivre un nouvelle carte donc on change seulement la date de délivrance
            .Range("q" & Lig).NumberFormat = "DD/MM/YYYY"
            .Range("q" & Lig).Value = Now
            'on compte le nombre de renouvellement
            RenouvX = RenouvX + 1
        End If
 
        .Range("r" & Lig).Value = RenouvX
        .Range("s" & Lig).Value = Li1
        .Range("t" & Lig).Value = Li2
        .Range("u" & Lig).Value = Li3
        .Range("y" & Lig).Value = anneesco
 
     ' procedure word
 
     ' mise en forme bordures
        With .Range("p" & Lig & ":y" & Lig)
            .HorizontalAlignment = xlCenter
        End With
        With Range("g" & Lig & ":i" & Lig)
            .HorizontalAlignment = xlCenter
        End With
        ' mise en forme conditionnelle des données dans la BDD
        With .Range("B" & Lig & ":y" & Lig) '.Select
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(LIGNE();2)"
            .FormatConditions(1).Interior.ColorIndex = 37
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlHairline
                .ColorIndex = xlAutomatic
            End With
        End With
        ' On décharge le formulaire et on affiche le nombre de renouvellements si renouv cochée
            If renouv = True Then MsgBox ("carte renouvellé" & RenouvX & " fois")
 
        'Place le après le End if si tu veux férmer ta UserForm y compris si le fihcier Doc n'est pas trouvé
        Unload Me
 
    End With
 
    Else
        Exit Sub
    End If
End Sub

Voila le début du code, pour le reste relit mes remarques précédentes, je n'ai pas l'intention de refaire toute ton indentation... par indentation, j'entend le fait de mettre une tabulation après un with, if, else, else if, For... par exemple, le code contenu entre un if et son end if de fermeture doit être au même niveau, ça facilite la lecture et évite les erreurs d'imbrication, ça ne demande aucune connaissance particulière, juste un peu d'effort.

Les Select peuvent également être supprimés en suivant l'exemple de début de code.
++
Qwaz

[patricktoulon]

bonjour

je suis assez d'accord avec quazerty

un code bien indenter et beaucoup plus facile a lire

pour ne pas se casser la tète avec ça il y a

smart indenter qui s'intègre très bien au menu contextuel dans le code lorsque que l'on est dans l'editeur vba

telecharge le ICI et choisi la version "Office 2000/2002/2003 " elle fonctionne aussi avec 2007

pour l'utiliser
click droite dans la partie code de l'editeur vbe et tu a plusieures option
le module en entier
la sub ou la fonction
tout les modules ect...


au plaisir

[nico77ssx]

Merci à toi, j'ai corrigé mes indents "à la main"

Et c'est au bureau, on ne peut pas installer de nouvelles choses, c'est bridé

[Qwazerty]

Salut
Impec, replace ton code pour voir ce qu'il est possible de faire.
++
Qwaz

[nico77ssx]

Il y a encore un passage "indent a donf" lol mais parce que je sais pas trop comment m'y prendre efficacement pour cette procédure (la recherche par secteur et/ou lot, ou tout ), bref. C'est juste pour m'aider.

Et j'ai toujours ce problème d'impression...

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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
 
Option Explicit
Dim L2 As Integer, SecVal As String
Dim i As Integer, ii As Integer, Recherche As String, RetNom As String, RetPrenom As String, RetNumcarte As String, RetSec As String, RetLot As String
Dim ind As Integer, txt As String, RetDNSS As String, RetLig As String, VarDNSS As String, ltxt0 As Integer
Dim Lig As Integer, Modif As Integer, RenouvX As Integer, NDF As String, NDF2 As String, DNSS As String, NomConverti As String, PrenomConverti As String
 
Private Sub BOUTONCREATION_Click()
    If MsgBox("Avez-vous rempli tous les champs spécifiques à votre service ?", vbQuestion + vbYesNo, "ATTENTION") = vbYes Then
    ' LA REPONSE EST "OUI"
 
    ' CHAMPS OBLIGATOIRES REMPLIS ?
    If Me.NOM.Text = "" Then
        MsgBox "Vous devez entrer un nom."
        Me.NOM.SetFocus
        Exit Sub
    End If
    If Me.PRENOM.Text = "" Then
        MsgBox "Vous devez entrer un prénom."
        Me.PRENOM.SetFocus
        Exit Sub
    End If
    If Me.civil.Text = "" Then
        MsgBox "Oubli de civilité"
        Me.civil.SetFocus
        Exit Sub
    End If
    If Me.JOURNSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.JOURNSS.SetFocus
        Exit Sub
    End If
    If Me.MOISNSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.MOISNSS.SetFocus
        Exit Sub
    End If
    If Me.ANNEENSS.Text = "" Then
        MsgBox "Date de naissance incomplète."
        Me.ANNEENSS.SetFocus
        Exit Sub
    End If
    If Me.STATUT.Text = "" Then
        MsgBox "Il faut un statut."
        Me.STATUT.SetFocus
        Exit Sub
    End If
    If Me.ADRESSE.Text = "" Then
        MsgBox "Adresse incomplète."
        Me.ADRESSE.SetFocus
        Exit Sub
    End If
    If Me.COMMUNE.Text = "" Then
        MsgBox "Commune de résidence non renseignée."
        Me.COMMUNE.SetFocus
        Exit Sub
    End If
    If Me.TELFIXE.Text = "" And Me.TELMOB = "" Then
        MsgBox "Au moins un téléphone obligatoire."
        Me.TELFIXE.SetFocus
        Exit Sub
    End If
    If Me.LR.Value = False And Me.CSS.Value = False Then
        MsgBox "Il faut choisir LR ou CSS"
        Exit Sub
    End If
        If Me.numcarte.Text = "" Then
        MsgBox "Numéro de carte non renseignée."
        Me.numcarte.SetFocus
        Exit Sub
    End If
 
' Conversion du nom et prénom en NOMPRPRE
    NomConverti = Application.WorksheetFunction.Proper(Me.NOM.Text)
    PrenomConverti = Application.WorksheetFunction.Proper(Me.PRENOM.Text)
' Selection derniere ligne ou modif
    With ThisWorkbook.Sheets("BDD")
    If Modif = 0 Then
        With .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        ' collage date de création dev la fiche et délivrance de la carte identiques puisque nouvelle fiche
             .NumberFormat = "DD/MM/YYYY"
             .Value = Now
             .Offset(0, 15).NumberFormat = "DD/MM/YYYY"
             .Offset(0, 15).Value = Now
             Lig = .Row
        End With
    End If
 
    ' Collage des donnees dans la BDD que ce soit création ou modification
    SecVal = Val(secteur)
    'If secval = 0 Then secval= ""
    .Range("C" & Lig).Value = civil
    .Range("d" & Lig).Value = NomConverti
    .Range("e" & Lig).Value = PrenomConverti
    .Range("f" & Lig).Value = STATUT
    DNSS = JOURNSS & "/" & MOISNSS & "/" & ANNEENSS
    .Range("g" & Lig).Value = DNSS
    .Range("h" & Lig).Value = TELFIXE
    .Range("i" & Lig).Value = TELMOB
    .Range("h" & Lig & ":i" & Lig).NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
    .Range("j" & Lig).Value = mel
    .Range("k" & Lig).Value = ADRESSE
    .Range("l" & Lig).Value = COMMUNE
    .Range("m" & Lig).Value = montee
    .Range("n" & Lig).Value = ets
    .Range("o" & Lig).Value = destiville
    .Range("p" & Lig).Value = numcarte
    If renouv = True Then
        'si on a coché la case renouv (ellement), on délivre un nouvelle carte donc on change seulement la date de délivrance
        .Range("q" & Lig).NumberFormat = "DD/MM/YYYY"
        .Range("q" & Lig).Value = Now
        'on compte le nombre de renouvellement
        RenouvX = RenouvX + 1
    End If
    .Range("r" & Lig).Value = RenouvX
    .Range("s" & Lig).Value = Li1
    .Range("t" & Lig).Value = Li2
    .Range("u" & Lig).Value = Li3
    .Range("v" & Lig).Value = SecVal
    .Range("w" & Lig).Value = lot
    .Range("x" & Lig).Value = classe
    .Range("y" & Lig).Value = anneesco
 
'ouverture word conditionnelle
If Modif = 0 Then
PourImpression
End If
 ' mise en forme bordures
    With .Range("p" & Lig & ":y" & Lig)
        .HorizontalAlignment = xlCenter
    End With
    With Range("g" & Lig & ":i" & Lig)
        .HorizontalAlignment = xlCenter
    End With
                ' mise en forme conditionnelle des données dans la BDD
    With .Range("B" & Lig & ":y" & Lig) '.Select
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(LIGNE();2)"
        .FormatConditions(1).Interior.ColorIndex = 37
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
    End With
    End With
' On décharge le formulaire et on affiche le nombre de renouvellements si renouv cochée
If renouv = True Then MsgBox ("carte renouvellé" & RenouvX & " fois")
'Place le après le End if si tu veux férmer ta UserForm y compris si le fihcier Doc n'est pas trouvé
Unload Me
 
        End With
 
    Else
        Exit Sub
    End If
End Sub
 
Private Sub BT_SEARCH_NOM_Click()
 
ListBox_NOM.Clear
Recherche = NOM.Text
ltxt0 = Len(Recherche)
If ltxt0 = 0 Then Exit Sub
Sheets("BDD").Select
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
For i = 8 To L2
RetNom = Cells(i, 4).Text
If UCase(Left(RetNom, ltxt0)) = UCase(Recherche) Then
  RetPrenom = Cells(i, 5).Text
  RetDNSS = Cells(i, 7).Text
ListBox_NOM.AddItem (Str(i) & " : " & RetNom & " " & RetPrenom & " " & RetDNSS)
End If
Next
 
'on regarde le contenu de ListBox1
Select Case ListBox_NOM.ListCount
    Case 0
        MsgBox "Rien trouvé"
 
    Case 1
    Lig = Val(ListBox_NOM.List(0))
        MoteurAffiche
    ListBox_NOM.Visible = False
    Case Else 'sinon montre la listbox pour faire un choix
    ListBox_NOM.Visible = True
End Select
 
End Sub
 
Private Sub CommandButton1_Click()
Sheets("creation").Select
Unload Me
End Sub
 
Private Sub BT_SEARCH_CARTE_Click()
' recherche coupon
 
ListBox_CARTE.Clear
Recherche = numcoupon.Text
ltxt0 = Len(Recherche)
If ltxt0 = 0 Then Exit Sub
Sheets("BDD").Select
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
For i = 8 To L2
RetNumcarte = Cells(i, 16).Text
If Left(RetNumcarte, ltxt0) = Recherche Then
 
  RetPrenom = Cells(i, 5).Text
  RetNom = Cells(i, 4).Text
  RetDNSS = Cells(i, 6).Text
ListBox_CARTE.AddItem (Str(i) & " : " & RetNom & " " & RetPrenom & " " & RetDNSS & " " & RetNumcarte)
End If
Next
 
Select Case ListBox_CARTE.ListCount
    Case 0
    MsgBox "Rien trouvé"
 
    Case 1
    Lig = Val(ListBox_CARTE.List(0))
    MoteurAffiche
    ListBox_CARTE.Visible = False
 
    Case Else
    ListBox_CARTE.Visible = True
End Select
 
End Sub
 
Private Sub BT_SEARCH_SCO_Click()
' generer liste
 
Sheets("bdd").Select
ActiveCell.SpecialCells(xlLastCell).Select
L2 = ActiveCell.Row
ListBox_SCO.Clear
'secteur=22 lot=23 nom=4 prenom=5 DNSS=7
 
   If secteur.Value <> "" Then
        Recherche = secteur.Value
        lot.Value = ""
        For i = 8 To L2
        RetSec = Cells(i, 22).Value
        If RetSec = Recherche Then
        RetNom = Cells(i, 4).Value
        RetPrenom = Cells(i, 5).Value
        RetDNSS = Cells(i, 7).Value
        RetLot = Cells(i, 23).Value
        ListBox_SCO.AddItem (Str(i) & " : Sect " & RetSec & " " & RetLot & " " & RetNom & " " & RetPrenom & " " & RetDNSS)
        End If
        Next
        secteur.Value = ""
 
    End If
 
    If secteur.Value = "" Then
        If lot.Value <> "" Then
            Recherche = lot.Value
            secteur.Value = ""
            For i = 8 To L2
            RetLot = Cells(i, 23).Value
            If RetLot = Recherche Then
            RetNom = Cells(i, 4).Value
            RetPrenom = Cells(i, 5).Value
            RetDNSS = Cells(i, 7).Value
            RetSec = Cells(i, 22).Value
            ListBox_SCO.AddItem (Str(i) & " : Sect " & RetSec & " " & RetLot & " " & RetNom & " " & RetPrenom & " " & RetDNSS)
            End If
            Next
            lot.Value = ""
        Else
            For ii = 1 To 4
            Recherche = ii
            For i = 8 To L2
            RetSec = Cells(i, 22).Value
            If RetSec = Recherche Then
            RetNom = Cells(i, 4).Value
            RetPrenom = Cells(i, 5).Value
            RetDNSS = Cells(i, 7).Value
            RetLot = Cells(i, 23).Value
            ListBox_SCO.AddItem (Str(i) & " : Sect " & RetSec & " " & RetLot & " " & RetNom & " " & RetPrenom & " " & RetDNSS)
            End If
            Next
            Next
        End If
    End If
 
End Sub
 
Private Sub CSS_Click()
 
NDF = "s:\tests\lettre scolaire.doc"
 
End Sub
 
Private Sub ListBox_NOM_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
ind = ListBox_NOM.ListIndex
Lig = Val(ListBox_NOM.List(ind))
ListBox_NOM.Visible = False
MoteurAffiche
 
End Sub
 
Private Sub ListBox_CARTE_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
ind = ListBox_CARTE.ListIndex
Lig = Val(ListBox_CARTE.List(ind))
ListBox_CARTE.Visible = False
MoteurAffiche
 
End Sub
 
Private Sub ListBox_SCO_dblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
ind = ListBox_SCO.ListIndex
Lig = Val(ListBox_SCO.List(ind))
ListBox_SCO.Visible = True
MoteurAffiche
 
End Sub
 
Private Sub LR_Click()
NDF = "s:\tests\lettre ligne reguliere.doc"
End Sub
 
Private Sub mel_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(LCase(Chr(KeyAscii)))
 
End Sub
 
Private Sub nom_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(LCase(Chr(KeyAscii)))
End Sub
 
Private Sub numcarte_keyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = Asc(UCase(Chr(KeyAscii)))
 
 
End Sub
Private Sub lot_keyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    KeyAscii = Asc(UCase(Chr(KeyAscii)))
 
 
End Sub
 
Private Sub OptionButton1_Click()
MsgBox "oui"
End Sub
 
Private Sub Telfixe_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    Case Is < 48, Is > 57
        KeyAscii = 0
    End Select
End Sub
Private Sub Telmob_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
    Case Is < 48, Is > 57
        KeyAscii = 0
    End Select
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub
 
Private Sub numcoupon_keypress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
 
End Sub
 
Private Sub UserForm_Initialize()
 
With NOM
    .SetFocus
    .SelStart = 0
 
End With
End Sub
Sub MoteurAffiche()
 
        If Range("v" & Lig).Value <> "" And Range("w" & Lig).Value <> "" Then
        Me.CSS.Value = True
        Else: Me.LR.Value = True
        End If
 
        civil = Range("C" & Lig).Value
        NOM = Range("d" & Lig).Value
        PRENOM = Range("e" & Lig).Value
        STATUT = Range("f" & Lig).Value
        VarDNSS = Range("g" & Lig).Value
        JOURNSS = Left(VarDNSS, 2)
        ANNEENSS = Right(VarDNSS, 4)
        MOISNSS = Mid(VarDNSS, 4, 2)
        TELFIXE = Range("h" & Lig).Value
        TELMOB = Range("i" & Lig).Value
        mel = Range("j" & Lig).Value
        ADRESSE = Range("k" & Lig).Value
        COMMUNE = Range("l" & Lig).Value
        montee = Range("m" & Lig).Value
        ets = Range("n" & Lig).Value
        destiville = Range("o" & Lig).Value
        numcarte = Range("p" & Lig).Value
        RenouvX = Range("r" & Lig).Value
        Li1 = Range("s" & Lig).Value
        Li2 = Range("t" & Lig).Value
        Li3 = Range("u" & Lig).Value
        secteur = Range("v" & Lig).Value
        lot = Range("w" & Lig).Value
        classe = Range("x" & Lig).Value
        anneesco = Range("y" & Lig).Value
        Modif = 1
End Sub
Sub PourImpression()
Dim ADRESSE1 As String, COMMUNE1 As String, civil1 As String
ADRESSE1 = CStr(ADRESSE)
COMMUNE1 = CStr(COMMUNE)
civil1 = CStr(civil)
 
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
 
 
NDF2 = "s:\tests\" & NomConverti & " " & PrenomConverti & ".doc"
 
On Error Resume Next
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
 
With WordApp
    .Visible = False
End With
With WordApp
    .Selection.Goto what:=wdGoToBookmark, Name:="adresse"
    .Selection.TypeText Text:=ADRESSE1
End With
With WordApp
    .Selection.Goto what:=wdGoToBookmark, Name:="nomprenom"
    .Selection.TypeText Text:=NomConverti & " " & PrenomConverti
End With
With WordApp
    .Selection.Goto what:=wdGoToBookmark, Name:="commune"
    .Selection.TypeText Text:=COMMUNE1
End With
With WordApp
    .Selection.Goto what:=wdGoToBookmark, Name:="civilite"
    .Selection.TypeText Text:=civil1
End With
With WordApp
    .Selection.Goto what:=wdGoToBookmark, Name:="civilite2"
    .Selection.TypeText Text:=civil1
End With
With WordApp
    .Selection.Goto what:=wdGoToBookmark, Name:="civilite3"
    .Selection.TypeText Text:=civil1
End With
'imprimer tout de suite ?
 
If MsgBox("Imprimer ?", vbQuestion + vbYesNo, "ATTENTION") = vbYes Then
 
With WordApp
Application.Dialogs(xlDialogPrinterSetup).Show
Application.PrintOut
 
    Application.PrintOut Filename:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
        ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
        False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
End With
 
End If
 
WordDoc.Application.ActiveDocument.SaveAs NDF2
WordApp.Application.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub