IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Optimisation de code


Sujet :

Macros et VBA Excel

  1. #1
    Membre averti
    Inscrit en
    Décembre 2006
    Messages
    19
    Détails du profil
    Informations forums :
    Inscription : Décembre 2006
    Messages : 19
    Par défaut Optimisation de code
    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"

  2. #2
    Expert confirmé
    Avatar de Qwazerty
    Homme Profil pro
    La très haute tension :D
    Inscrit en
    Avril 2002
    Messages
    4 104
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 45
    Localisation : France

    Informations professionnelles :
    Activité : La très haute tension :D
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2002
    Messages : 4 104
    Par défaut
    Salut

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

    ++
    Qwaz

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  3. #3
    Membre averti
    Inscrit en
    Décembre 2006
    Messages
    19
    Détails du profil
    Informations forums :
    Inscription : Décembre 2006
    Messages : 19
    Par défaut
    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.

  4. #4
    Expert confirmé
    Avatar de Qwazerty
    Homme Profil pro
    La très haute tension :D
    Inscrit en
    Avril 2002
    Messages
    4 104
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 45
    Localisation : France

    Informations professionnelles :
    Activité : La très haute tension :D
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2002
    Messages : 4 104
    Par défaut
    Citation Envoyé par nico77ssx Voir le message
    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

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  5. #5
    Membre averti
    Inscrit en
    Décembre 2006
    Messages
    19
    Détails du profil
    Informations forums :
    Inscription : Décembre 2006
    Messages : 19
    Par défaut
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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

  6. #6
    Expert confirmé
    Avatar de Qwazerty
    Homme Profil pro
    La très haute tension :D
    Inscrit en
    Avril 2002
    Messages
    4 104
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 45
    Localisation : France

    Informations professionnelles :
    Activité : La très haute tension :D
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2002
    Messages : 4 104
    Par défaut
    Salut

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

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    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

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  7. #7
    Membre averti
    Inscrit en
    Décembre 2006
    Messages
    19
    Détails du profil
    Informations forums :
    Inscription : Décembre 2006
    Messages : 19
    Par défaut
    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

  8. #8
    Membre averti
    Inscrit en
    Décembre 2006
    Messages
    19
    Détails du profil
    Informations forums :
    Inscription : Décembre 2006
    Messages : 19
    Par défaut
    Voila, version épurée ! encore des trucs à améliorer je pense

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    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

  9. #9
    Expert confirmé
    Avatar de Qwazerty
    Homme Profil pro
    La très haute tension :D
    Inscrit en
    Avril 2002
    Messages
    4 104
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 45
    Localisation : France

    Informations professionnelles :
    Activité : La très haute tension :D
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2002
    Messages : 4 104
    Par défaut
    Salut

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    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

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  10. #10
    Inactif  

    Homme Profil pro
    cuisiniste
    Inscrit en
    Avril 2009
    Messages
    15 374
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Var (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : cuisiniste
    Secteur : Bâtiment

    Informations forums :
    Inscription : Avril 2009
    Messages : 15 374
    Billets dans le blog
    8
    Par défaut heu!!!
    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
    mes fichiers dans les contributions:
    mail avec CDO en vba et mail avec CDO en vbs dans un HTA
    survol des bouton dans userform
    prendre un cliché d'un range

    si ton problème est résolu n'oublie pas de pointer : : ça peut servir aux autres
    et n'oublie pas de voter

  11. #11
    Membre averti
    Inscrit en
    Décembre 2006
    Messages
    19
    Détails du profil
    Informations forums :
    Inscription : Décembre 2006
    Messages : 19
    Par défaut
    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é

  12. #12
    Expert confirmé
    Avatar de Qwazerty
    Homme Profil pro
    La très haute tension :D
    Inscrit en
    Avril 2002
    Messages
    4 104
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 45
    Localisation : France

    Informations professionnelles :
    Activité : La très haute tension :D
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2002
    Messages : 4 104
    Par défaut
    Salut
    Impec, replace ton code pour voir ce qu'il est possible de faire.
    ++
    Qwaz

    MagicQwaz := Harry Potter la baguette en moins
    Le monde dans lequel on vit
    Ma page perso DVP
    Dernier et Seul Tutoriel : VBA & Internet Explorer
    Dernière contribution : Lien Tableau Structuré et UserForm
    L'utilisation de l’éditeur de message

  13. #13
    Membre averti
    Inscrit en
    Décembre 2006
    Messages
    19
    Détails du profil
    Informations forums :
    Inscription : Décembre 2006
    Messages : 19
    Par défaut
    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 : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    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

Discussions similaires

  1. optimiser le code d'une fonction
    Par yanis97 dans le forum MS SQL Server
    Réponses: 1
    Dernier message: 15/07/2005, 08h41
  2. Optimiser mon code ASP/HTML
    Par ahage4x4 dans le forum ASP
    Réponses: 7
    Dernier message: 30/05/2005, 10h29
  3. optimiser le code
    Par bibi2607 dans le forum ASP
    Réponses: 3
    Dernier message: 03/02/2005, 14h30
  4. syntaxe et optimisation de codes
    Par elitol dans le forum Langage SQL
    Réponses: 18
    Dernier message: 12/08/2004, 11h54
  5. optimisation du code et var globales
    Par tigrou2405 dans le forum ASP
    Réponses: 2
    Dernier message: 23/01/2004, 10h59

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo