Code VBA perdu ?

**adou92150** · 13/03/2012, 12h09

D'abord.. Bonjour ^^

Ensuite mon (gros) problème :
Excel m'a buggé alors qu'une userform était chargée et j'ai du forcer l'arrêt.
Maintenant quand j'ouvre à nouveau le fichier j'ai les messages suivants :
1. Des erreurs se sont produites au cours du chargement
2. MVB : Impossible de charger ou decharger cet objet

Là il propose des "réparations" pour utiliser le fichier, ce qui consiste à virer tout le projet VBA et j'ai "Projet Visual Basic perdu". => Super !...

Vous l'aurez compris, j'aimerai savoir comment récupérer mon code (tout ou partie) afin de pas tout refaire. (bien sûr je n'avais de fichier de sauvegarde (comme un gros c** que j'suis

)). Please help !!!

Je précise que si on décide par la suite d'enregistrer le fichier en acceptant la perte du vba, la taille du fichier diminue grandement, ce qui à mon sens montre qu'il y a bien encore le code quelque part...

Par avance merci à tous ceux qui vont se pencher un peu sur mon problème.

**Jean-Philippe André** · 13/03/2012, 12h34

dans ton onglet FeuilVBA, je tombe sur

DES INSERTIONS DE LIGNE(S) OU COLONNE(S) DANS CET ONGLET PEUVENT TOUT FAIRE PLANTER !!!!

ca pose potentiellement déjà un problème de conception de ton classeur, non ?

Dans ta PJ, on n'a aucun code VBA de disponible, le fichier faisant 112Ko, donc rien de bien gros

**Daniel.C** · 13/03/2012, 12h36

Bonjour,
Est-ce que tu veux dire que tu as fais les réparations proposées sans dupliquer ton ficher ? Là, tu es mal. Sinon, mets le fichier non "réparé" en pièce jointe.

**adou92150** · 13/03/2012, 15h50

Effectivement, 'ai pas été malin sur ce coup, ci-joint le fichier à problème.

Concernant le message d'alerte sur l'onglet FeuilVBA, c'est simplement un bref rappel pour ma pomme. En fait cette feuille sera plus tard rendue inaccessible et pour l'instant j'ai un bout de code qui fait référence à des cellules de la feuille et non à des noms de cellules ou de zone. C'est donc juste pour me rappeler ceci.

Merci.

**Daniel.C** · 13/03/2012, 18h12

En ouvrant le fichier avec OpenOffice, je récupère ce qui suit, en espérant que ça te concerne... Par contre, si on voit les userforms en ouvrant le fichier avec OO et en regardant du côté des macros, je n'ai pas trouvé comment les exporter. Tu peux faire la même manip pour les voir et les refaire.

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
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
Rem Attribute VBA_ModuleType=VBAModule
Sub Alertes
Rem Sub Alerte0()
Rem MsgBox "La liste des valeurs est restreinte aux propositions suivantes :" & Chr(10) & _
Rem     "   - Par proportion (plancher)" & Chr(10) & _
Rem     "   - Par proportion (plafond)" & Chr(10) & _
Rem     "   - Rang (plancher)" & Chr(10) & _
Rem     "   - Rang (plafond)" & Chr(10) & _
Rem     "   - Appréciation"
Rem Application.EnableEvents = True
Rem End
Rem End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil10
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem If Target.Row = ActiveSheet.Range("Entre_dans_scoring").Row + 1 Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column <= ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Entre_dans_scoring") Then
Rem             
Rem         End If
Rem     End If
Rem End If
Rem 
Rem If Target.Column = Range("Methode").Column Then Call Scoring
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil2
Rem Dim Cible As Variant
Rem 
Rem Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem If Target.Row >= ActiveSheet.Range("Entre_dans_scoring").Row + 3 And Target.Row <= ActiveSheet.Range("Fin").Row Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column < ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Nb_ass") Then
Rem             Cible = Target.Value
Rem             Cible_Row = Target.Row
Rem         End If
Rem     End If
Rem End If
Rem End Sub
Rem 
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem Application.EnableEvents = False
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem Cible_Row = Target.Row
Rem Cible_Col = Target.Column
Rem 
Rem 'Actions sur la colonne Méthode si on modifie les notes :
Rem If Target.Row >= ActiveSheet.Range("Entre_dans_scoring").Row + 3 And Target.Row <= ActiveSheet.Range("Fin").Row Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column < ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Nb_ass") Then
Rem             Cible_Row = Target.Row
Rem             If Target.Value <> Cible And Cells(Cible_Row, Range("Methode").Column) <> "" Then
Rem                 Cells(Cible_Row, Range("Methode").Column) = "Appréciation"
Rem                 Application.EnableEvents = True
Rem                 End
Rem             End If
Rem             If Target.Value = "" And Cible = 0 And Cells(Cible_Row, Range("Methode").Column) <> "" Then
Rem                 Cells(Cible_Row, Range("Methode").Column) = "Appréciation"
Rem                 Application.EnableEvents = True
Rem                 End
Rem             End If
Rem             If Target.Value = 0 And Cible = "" And Cells(Cible_Row, Range("Methode").Column) <> "" Then
Rem                 Cells(Cible_Row, Range("Methode").Column) = "Appréciation"
Rem                 Application.EnableEvents = True
Rem                 End
Rem             End If
Rem         End If
Rem     End If
Rem End If
Rem 
Rem 'MAJ des calculs si on valide l'entrée dans le scoring d'un autre candidat
Rem If Target.Row = ActiveSheet.Range("Entre_dans_scoring").Row + 1 Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column < ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Nb_ass") Then
Rem             If Target.Value = "Oui" Then Call Calc_methodes
Rem         End If
Rem     End If
Rem End If
Rem 
Rem 'Calcul des scores pour une méthode choisie
Rem If Target.Column = Range("Methode").Column And Target.Row <= ActiveSheet.Range("Fin").Row Then Call Scoring
Rem 
Rem Application.EnableEvents = True
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil3
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem Dim Plage As Range
Rem Set Plage = Range("Codes_associes")
Rem 
Rem If Not (Application.Intersect(Target, Plage) Is Nothing) Then
Rem     If Target.Value = "" Then Target.Value = 0
Rem     If IsNumeric(Target.Value) Then
Rem         Nb_ass = Range("Nb_ass")
Rem         lig = Target.Row
Rem         col_start = Range("Ass1").Column
Rem         
Rem         Dim TableauLigCodes() As Integer 'on y mettra pour chaque code associé la ligne de la zone Codes où se situe les valeurs cibles
Rem         ReDim TableauLigCodes(Range("Nb_agreg").Value - 1)
Rem         
Rem         Dim TableauCoeffs() As Integer 'on y mettra les différents coefficients associés aux codes
Rem         ReDim TableauCoeffs(Range("Nb_agreg").Value - 1)
Rem         
Rem         Dim TableauNotes() As Integer 'on y mettra les différentes notes associés aux codes
Rem         ReDim TableauNotes(Range("Nb_agreg").Value - 1)
Rem         
Rem         
Rem         For i = 0 To Range("Nb_ass").Value - 1
Rem             For j = 0 To Range("Nb_agreg").Value - 1
Rem                 If Cells(lig, Range("Nb_agreg").Column + j) > 0 Then
Rem                     TableauLigCodes(j) = Application.WorksheetFunction.Match(Cells(lig, Range("Nb_agreg").Column + j), Range("Codes"), 0)
Rem                     TableauCoeffs(j) = Range("Nb_ass").Offset(TableauLigCodes(j) - 1, Nb_ass + 1)
Rem                     TableauNotes(j) = Range("Nb_ass").Offset(TableauLigCodes(j) - 1, i + 1)
Rem                 Else
Rem                     TableauLigCodes(j) = 0
Rem                     TableauCoeffs(j) = 0
Rem                     TableauNotes(j) = 0
Rem                 End If
Rem             Next j
Rem             
Rem             'calcul de la note pondérée :
Rem             sumprod = 0
Rem             For k = 0 To Range("Nb_agreg").Value - 1
Rem                 sumprod = sumprod + TableauNotes(k) * TableauCoeffs(k)
Rem             Next k
Rem             sumcoef = Application.WorksheetFunction.Sum(TableauCoeffs())
Rem             
Rem             If sumcoef = 0 Then
Rem                 Cells(lig, col_start + i) = 0
Rem             Else
Rem                 Cells(lig, col_start + i) = sumprod / sumcoef
Rem             End If
Rem         Next i
Rem     End If
Rem End If
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil4
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem If Target.Row = ActiveSheet.Range("Entre_dans_scoring").Row + 1 Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column <= ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Entre_dans_scoring") Then
Rem             
Rem         End If
Rem     End If
Rem End If
Rem 
Rem If Target.Column = Range("Methode").Column Then Call Scoring
Rem 
Rem End Sub
Rem 
End Sub
Rem 
Rem Sub Alerte1()
Rem MsgBox "Les méthodes de notation" & Chr(10) & _
Rem     "   - Par proportion (plancher)" & Chr(10) & _
Rem     "   - Par proportion (plafond)" & Chr(10) & _
Rem     "   - Rang (plancher)" & Chr(10) & _
Rem     "   - Rang (plafond)" & Chr(10) & _
Rem     "sont utilisables uniquement dans le cas de valeurs numériques." & Chr(10) & Chr(10) & _
Rem     "(Pour rappel : le vide ' ' n'est pas une valeur numérique.)"
Rem Application.EnableEvents = True
Rem End
Rem End Sub
Rem 
Rem Sub Alerte2()
Rem MsgBox "Les méthodes de notation" & Chr(10) & _
Rem     "   - Par proportion (plancher)" & Chr(10) & _
Rem     "   - Par proportion (plafond)" & Chr(10) & _
Rem     "sont utilisables uniquement dans le cas où les réponses de valeurs numériques sont de même signe."
Rem Application.EnableEvents = True
Rem End
Rem End Sub
Rem 
Rem Sub Alerte3()
Rem MsgBox "La méthode de notation" & Chr(10) & _
Rem     "   - Par proportion (plafond)" & Chr(10) & _
Rem     "n'est pas utilisable dans le cas où les réponses sont des valeurs négatives avec au moins une valeur nulle."
Rem Application.EnableEvents = True
Rem End
Rem End Sub
Rem 
Rem Sub Alerte4()
Rem MsgBox "La méthode de notation" & Chr(10) & _
Rem     "   - Par proportion (plancher)" & Chr(10) & _
Rem     "n'est pas utilisable dans le cas où les réponses sont des valeurs positives avec au moins une valeur nulle."
Rem Application.EnableEvents = True
Rem End
Rem End Sub
Rem 
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil1
Rem Private Sub CommandButton1_Click()
Rem UserForm1.Show
Rem End Sub
Rem 
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem Dim Plage As Range
Rem Set Plage = Range("Codes_associes")
Rem 
Rem If Not (Application.Intersect(Target, Plage) Is Nothing) Then
Rem     If Target.Value = "" Then Target.Value = 0
Rem     If IsNumeric(Target.Value) Then
Rem         Nb_ass = Range("Nb_ass")
Rem         lig = Target.Row
Rem         col_start = Range("Ass1").Column
Rem         
Rem         Dim TableauLigCodes() As Integer 'on y mettra pour chaque code associé la ligne de la zone Codes où se situe les valeurs cibles
Rem         ReDim TableauLigCodes(Range("Nb_agreg").Value - 1)
Rem         
Rem         Dim TableauCoeffs() As Integer 'on y mettra les différents coefficients associés aux codes
Rem         ReDim TableauCoeffs(Range("Nb_agreg").Value - 1)
Rem         
Rem         Dim TableauNotes() As Integer 'on y mettra les différentes notes associés aux codes
Rem         ReDim TableauNotes(Range("Nb_agreg").Value - 1)
Rem         
Rem         
Rem         For i = 0 To Range("Nb_ass").Value - 1
Rem             For j = 0 To Range("Nb_agreg").Value - 1
Rem                 If Cells(lig, Range("Nb_agreg").Column + j) > 0 Then
Rem                     TableauLigCodes(j) = Application.WorksheetFunction.Match(Cells(lig, Range("Nb_agreg").Column + j), Range("Codes"), 0)
Rem                     TableauCoeffs(j) = Range("Nb_ass").Offset(TableauLigCodes(j) - 1, Nb_ass + 1)
Rem                     TableauNotes(j) = Range("Nb_ass").Offset(TableauLigCodes(j) - 1, i + 1)
Rem                 Else
Rem                     TableauLigCodes(j) = 0
Rem                     TableauCoeffs(j) = 0
Rem                     TableauNotes(j) = 0
Rem                 End If
Rem             Next j
Rem             
Rem             'calcul de la note pondérée :
Rem             sumprod = 0
Rem             For k = 0 To Range("Nb_agreg").Value - 1
Rem                 sumprod = sumprod + TableauNotes(k) * TableauCoeffs(k)
Rem             Next k
Rem             sumcoef = Application.WorksheetFunction.Sum(TableauCoeffs())
Rem             
Rem             If sumcoef = 0 Then
Rem                 Cells(lig, col_start + i) = 0
Rem             Else
Rem                 Cells(lig, col_start + i) = sumprod / sumcoef
Rem             End If
Rem         Next i
Rem     End If
Rem End If
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil5
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem If Target.Row = ActiveSheet.Range("Entre_dans_scoring").Row + 1 Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column <= ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Entre_dans_scoring") Then
Rem             
Rem         End If
Rem     End If
Rem End If
Rem 
Rem If Target.Column = Range("Methode").Column Then Call Scoring
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil6
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem If Target.Row = ActiveSheet.Range("Entre_dans_scoring").Row + 1 Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column <= ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Entre_dans_scoring") Then
Rem             
Rem         End If
Rem     End If
Rem End If
Rem 
Rem If Target.Column = Range("Methode").Column Then Call Scoring
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil8
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem If Target.Row = ActiveSheet.Range("Entre_dans_scoring").Row + 1 Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column <= ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Entre_dans_scoring") Then
Rem             
Rem         End If
Rem     End If
Rem End If
Rem 
Rem If Target.Column = Range("Methode").Column Then Call Scoring
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Feuil9
Rem Private Sub Worksheet_Change(ByVal Target As Range)
Rem 
Rem If Target.Count > 1 Then Exit Sub
Rem 'permet de sortir de la procédure si plus d'une cellule est sélectionnée
Rem '(sinon la suite de la macro renvoie un message d'erreur)
Rem 
Rem If Target.Row = ActiveSheet.Range("Entre_dans_scoring").Row + 1 Then
Rem     If Target.Column >= ActiveSheet.Range("Entre_dans_scoring").Column Then
Rem         If Target.Column <= ActiveSheet.Range("Entre_dans_scoring").Column + ActiveSheet.Range("Entre_dans_scoring") Then
Rem             
Rem         End If
Rem     End If
Rem End If
Rem 
Rem If Target.Column = Range("Methode").Column Then Call Scoring
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBAModule
Sub Fonctions
Rem Function copie_colle_Tout(lig_deb As Integer, lig_fin As Integer, col_deb As Integer, col_fin As Integer, lig_cible As Integer, col_cible As Integer)
Rem 
Rem ActiveSheet.Range(Cells(lig_deb, col_deb), Cells(lig_fin, col_fin)).Copy
Rem ActiveSheet.Cells(lig_cible, col_cible).PasteSpecial Paste:=xlPasteAll
Rem Application.CutCopyMode = False
Rem 
Rem End Function
Rem 
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBAModule
Sub Mises_en_forme
Rem Dim lig_deb As Integer, lig_fin As Integer, col_deb As Integer, col_fin As Integer, lig_cible As Integer, col_cible As Integer
Rem 
Rem Sub MEF_Scoring1() 'Mise en forme du tableau de synthèse dans l'onglet Scoring
Rem 
Rem lig_deb = Range("Ass1").Row
Rem col_deb = Range("Ass1").Column
Rem lig_fin = Range("Fin1").Row
Rem col_fin = col_deb
Rem lig_cible = lig_deb
Rem 
Rem For i = 1 To Nb_candidatures - Range("Nb_ass")
Rem     col_cible = col_deb + Range("Nb_ass") + i - 1
Rem     Action = copie_colle_Tout(lig_deb, lig_fin, col_deb, col_fin, lig_cible, col_cible)
Rem     
Rem     Range(Cells(lig_deb + 2, col_cible), Cells(lig_fin, col_cible)).ClearContents
Rem     
Rem     For j = 1 To lig_fin - (lig_deb + 2)
Rem         If InStr(Cells(lig_deb + 1 + j, col_deb - 2), "Total") > 0 Then _
Rem         Action = copie_colle_Tout(lig_deb + 1 + j, lig_deb + 1 + j, col_deb, col_deb, lig_deb + 1 + j, col_cible)
Rem     Next j
Rem Next i
Rem 
Rem End Sub
Rem 
Rem Sub MEF_Scoring2()
Rem 
Rem For j = 1 To Nb_candidatures - Range("Nb_ass")
Rem     lig_deb = Range("Nb_ass").Row
Rem     lig_fin = lig_deb
Rem     col_deb = Range("Nb_ass").Column + 1
Rem     col_fin = col_deb
Rem     lig_cible = lig_deb
Rem     col_cible = col_deb + Range("Nb_ass") + j - 1
Rem     Action = copie_colle_Tout(lig_deb, lig_fin, col_deb, col_fin, lig_cible, col_cible)
Rem Next j
Rem 
Rem End Sub
Rem Sub MEF_Entrent_dans_le_scoring()
Rem 
Rem lig = Range("Entre_dans_scoring").Row
Rem col = Range("Entre_dans_scoring").Column
Rem Range(Cells(lig, col), Cells(lig, col + Range("Nb_ass") - 1)).Merge
Rem lig2 = Range("Methode").Row
Rem Range(Cells(lig2, col), Cells(lig2, col + Range("Nb_ass") - 1)).Merge
Rem 
Rem lig_deb = Range("Entre_dans_scoring").Row + 1
Rem lig_fin = lig_deb
Rem col_deb = col
Rem col_fin = col_deb
Rem lig_cible = lig_deb
Rem col_cible = col_deb + Worksheets(Feuille_Scoring).Range("Nb_ass") + j - 1
Rem Action = copie_colle_Tout(lig_deb, lig_fin, col_deb, col_fin, lig_cible, col_cible)
Rem 
Rem lig3 = Range("Entre_dans_scoring").Row + 1
Rem For i = 1 To Nb_candidatures - Worksheets(Feuille_Scoring).Range("Nb_ass")
Rem     col3 = Range("Entre_dans_scoring").Column + Worksheets(Feuille_Scoring).Range("Nb_ass") - 1 + i
Rem     Cells(lig3, col3).Select
Rem     Call Bordures_1
Rem Next i
Rem 
Rem End Sub
Rem 
Rem Sub Bordures_1()
Rem Range("G2").Select
Rem     With Selection.Borders(xlEdgeLeft)
Rem         .LineStyle = xlContinuous
Rem         .Weight = xlThin
Rem         .ColorIndex = xlAutomatic
Rem     End With
Rem     With Selection.Borders(xlEdgeTop)
Rem         .LineStyle = xlContinuous
Rem         .Weight = xlThin
Rem         .ColorIndex = xlAutomatic
Rem     End With
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBAModule
Sub Nbr_Candidatures
Rem Sub Ajout_Col()
Rem 
Rem Dim Plage As Range
Rem Dim Nm As Name
Rem Dim lig_deb As Integer, lig_fin As Integer, col_deb As Integer, col_fin As Integer, lig_cible As Integer, col_cible As Integer
Rem 
Rem On Error Resume Next
Rem 
Rem 'Rajout des colonnes dans le tableau récapitulatif de l'onglet Scoring
Rem col_deb = Range("Nb_ass").Column + Range("Nb_ass") + 1
Rem col_fin = col_deb + Nb_candidatures - Range("Nb_ass") - 1
Rem Range(Cells(60000, col_deb), Cells(60000, col_fin)).Select
Rem Selection.EntireColumn.Insert Shift:=xlToRight
Rem 
Rem For i = 1 To Worksheets.Count
Rem     For Each Nm In ThisWorkbook.Names 'Rajout des colonnes dans chaque onglet où apparait le nom de cellule "Ass1"
Rem         Set Plage = Nm.RefersToRange
Rem         
Rem         If Not Plage Is Nothing Then
Rem             'Vérifie si le nom appartient à la feuille
Rem             If Worksheets(i).Name = Plage.Worksheet.Name Then
Rem                 If InStr(Nm.Name, "Ass1") > 0 Then
Rem                     Worksheets(i).Activate
Rem                     
Rem                     col_deb = Worksheets(i).Range("Ass1").Column + Worksheets(i).Range("Nb_ass")
Rem                     col_fin = col_deb + Nb_candidatures - Range("Nb_ass") - 1
Rem                     Worksheets(i).Range(Cells(60000, col_deb), Cells(60000, col_fin)).Select
Rem                     Selection.EntireColumn.Insert Shift:=xlToRight
Rem                     
Rem                     Worksheets(i).Range("A1").Select
Rem                 End If
Rem                 If InStr(Nm.Name, "Methode") > 0 Then
Rem                     Worksheets(i).Activate
Rem                                         
Rem                     col_deb = Worksheets(i).Range("Methode").Column
Rem                     col_fin = col_deb + Nb_candidatures - Worksheets(Feuille_Scoring).Range("Nb_ass") - 1
Rem                     Worksheets(i).Range(Cells(60000, col_deb), Cells(60000, col_fin)).Select
Rem                     Selection.EntireColumn.Insert Shift:=xlToRight
Rem                     
Rem                     Call MEF_Entrent_dans_le_scoring
Rem                     Worksheets(i).Range("A1").Select
Rem                 End If
Rem             End If
Rem         End If
Rem         
Rem         Set Plage = Nothing
Rem     Next Nm
Rem     
Rem     For Each Nm In ThisWorkbook.Names 'Rajout des noms des candidats"
Rem         Set Plage = Nm.RefersToRange
Rem         
Rem         If Not Plage Is Nothing Then
Rem             'Vérifie si le nom appartient à la feuille
Rem             If Worksheets(i).Name = Plage.Worksheet.Name Then
Rem                 If InStr(Nm.Name, "Entre_dans_scoring") > 0 Then
Rem                     Worksheets(i).Activate
Rem                     For j = 1 To Nb_candidatures - Worksheets(Feuille_Scoring).Range("Nb_ass")
Rem                         lig_deb = Worksheets(i).Range("Ass1").Row
Rem                         lig_fin = lig_deb
Rem                         col_deb = Worksheets(i).Range("Ass1").Column
Rem                         col_fin = col_deb
Rem                         lig_cible = lig_deb
Rem                         col_cible = col_deb + Worksheets(Feuille_Scoring).Range("Nb_ass") + j - 1
Rem                         Action = copie_colle_Tout(lig_deb, lig_fin, col_deb, col_fin, lig_cible, col_cible)
Rem                     Next j
Rem                     Worksheets(i).Range("A1").Select
Rem                 End If
Rem             End If
Rem         End If
Rem         
Rem         Set Plage = Nothing
Rem     Next Nm
Rem Next i
Rem 
Rem Worksheets(Feuille_Scoring).Activate
Rem     
Rem End Sub
Rem 
Rem Sub Suppr_Col()
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBAModule
Sub Scoring_Onglets
Rem Sub Scoring()
Rem 
Rem Select Case Cells(Cible_Row, Cible_Col).Value
Rem     Case "Rang (plafond)"
Rem     Case "Rang (plancher)"
Rem     Case "Par proportion (plafond)"
Rem     Case "Par proportion (plancher)"
Rem     Case "Appréciation"
Rem         Application.EnableEvents = True
Rem         End
Rem     Case ""
Rem         Application.EnableEvents = True
Rem         End
Rem     Case Else
Rem         Cells(Cible_Row, Cible_Col).ClearContents
Rem         Call Alerte0
Rem End Select
Rem     
Rem Application.EnableEvents = False
Rem 
Rem     Nb_ass = ActiveSheet.Range("Nb_ass").Value 'nombre de candidatures (colonnes) possibles à évaluer dans la feuille
Rem     Max_points = 5
Rem     Dim Plage1, Plage2 As Range
Rem     Dim Arret_tri As Integer
Rem     Dim Cible As Variant
Rem 
Rem     col = ActiveSheet.Range("Entre_dans_scoring").Column 'colonne de la note du 1er candidat
Rem     lig = ActiveSheet.Range("Entre_dans_scoring").Row + 1 'ligne du fichier qui dit si on note le candidat
Rem     lig_active = Cible_Row
Rem     
Rem     nb = ActiveSheet.Range("Entre_dans_scoring").Value
Rem     
Rem     Dim TableauCol() As Integer 'on définit le vecteur de: numéro de colonnes qui seront affiliées d'une note
Rem     ReDim TableauCol(nb - 1)
Rem     
Rem     Dim TableauColAss() As Integer 'on définit le vecteur de: colonnes qui sont les colonnes des réponses à noter
Rem     ReDim TableauColAss(nb - 1)
Rem     
Rem     Dim TableauValAss() As Variant 'on définit le vecteur de: réponses qui sont dans les colonnes des réponses à noter
Rem     ReDim TableauValAss(nb - 1)
Rem     
Rem     Dim TableauValAssTrié() As Variant 'on définit le vecteur de: réponses qui sont dans les colonnes des réponses à noter et qui seront triées dans l'ordre croissant
Rem     ReDim TableauValAssTrié(nb - 1)
Rem     
Rem     j = -1
Rem     k = 0
Rem     inc = 0
Rem     
Rem     Sheets("FeuilVBA").Range("A2:A6").ClearContents
Rem     Sheets("FeuilVBA").Range("B8") = nb
Rem     
Rem     For i = col To col * 10 'i commence à la colonne note du 1er candidat
Rem         If Cells(lig, i) = "Oui" Then
Rem             inc = inc + 1
Rem             j = j + 1
Rem             TableauCol(j) = Cells(lig, i).Column 'on remplit nos vecteurs qu'on a défini au début
Rem             TableauColAss(j) = Cells(lig, i - Nb_ass).Column
Rem             TableauValAss(j) = Cells(lig_active, TableauColAss(j)).Value
Rem             Sheets("FeuilVBA").Range("A" & 2 + k) = TableauValAss(j)
Rem             k = k + 1
Rem             TableauValAssTrié(j) = TableauValAss(j)
Rem             
Rem             If TableauValAss(j) = "" Or Not (IsNumeric(TableauValAss(j))) Then
Rem                 Call Alerte1
Rem             End If
Rem             
Rem             Max = Application.WorksheetFunction.Max(TableauValAss())
Rem             'If Max = TableauValAss(j) Then Col_max = TableauColAss(j) 'on définit la colonne qui contient la valeur max
Rem             
Rem             Min = Application.WorksheetFunction.Min(TableauValAss())
Rem             'If Min = TableauValAss(j) Then Col_min = TableauColAss(j) 'on définit la colonne qui contient la valeur min
Rem             
Rem             If inc = nb Then i = col * 10
Rem         End If
Rem     Next i
Rem     inc = 0
Rem     i = 0
Rem     k = 0
Rem     
Rem     Do 'tri décroissant
Rem         Arret_tri = 0
Rem         For i = 0 To UBound(TableauValAssTrié) - 1
Rem             If TableauValAssTrié(i) < TableauValAssTrié(i + 1) Then
Rem                 Cible = TableauValAssTrié(i)
Rem                 TableauValAssTrié(i) = TableauValAssTrié(i + 1)
Rem                 TableauValAssTrié(i + 1) = Cible
Rem                 Arret_tri = 1
Rem             End If
Rem         Next i
Rem     Loop While Arret_tri = 1
Rem     i = 0
Rem     
Rem     'on appele Plage1 la zone du tableau trié
Rem     Set Plage1 = Sheets("FeuilVBA").Range("B17:F17")
Rem     Plage1.ClearContents
Rem     For i = 0 To nb - 1
Rem         Sheets("FeuilVBA").Cells(17, 2 + i) = TableauValAssTrié(i)
Rem     Next i
Rem     i = 0
Rem 
Rem     'on appele Plage2 la zone de score de la ligne active
Rem     Set Plage2 = ActiveSheet.Range(Cells(lig_active, col), Cells(lig_active, Cells(Cible_Row, Cible_Col).Column - 1))
Rem     
Rem     Select Case Cells(Cible_Row, Cible_Col).Value
Rem                 
Rem         Case "Rang (plafond)"
Rem             Plage2.ClearContents
Rem             For i = 0 To nb - 1
Rem                 Cells(lig_active, TableauCol(i)) = Sheets("FeuilVBA").Range("B" & i + 2)
Rem             Next i
Rem         
Rem         Case "Rang (plancher)"
Rem             Plage2.ClearContents
Rem             For i = 0 To nb - 1
Rem                 Cells(lig_active, TableauCol(i)) = Sheets("FeuilVBA").Range("C" & i + 2)
Rem             Next i
Rem         
Rem         Case "Par proportion (plafond)" 'correspond à une règle de 3
Rem             Plage2.ClearContents
Rem             If Sheets("FeuilVBA").Range("Alerte") = 5 Then
Rem                 Call Alerte2
Rem             End If
Rem             If Sheets("FeuilVBA").Range("Alerte") = 4 Then
Rem                 Call Alerte3
Rem             End If
Rem             For i = 0 To nb - 1
Rem                 Cells(lig_active, TableauCol(i)) = Sheets("FeuilVBA").Range("D" & i + 2)
Rem             Next i
Rem             
Rem         Case "Par proportion (plancher)"
Rem             Plage2.ClearContents
Rem             If Sheets("FeuilVBA").Range("Alerte") = 5 Then
Rem                 Call Alerte2
Rem             End If
Rem             If Sheets("FeuilVBA").Range("Alerte") = 2 Then
Rem                 Call Alerte4
Rem             End If
Rem             For i = 0 To nb - 1
Rem                 Cells(lig_active, TableauCol(i)) = Sheets("FeuilVBA").Range("E" & i + 2)
Rem             Next i
Rem         
Rem     End Select
Rem     i = 0
Rem     j = 0
Rem     l = 0
Rem 
Rem End Sub
Rem 
Rem Sub Calc_methodes()
Rem 
Rem For i = 1 To Range("Fin").Row - Range("Methode").Row
Rem     If Range("Methode").Offset(i, 0) <> "" And Range("Methode").Offset(i, 0) <> "Appréciation" Then
Rem         Cible_Row = Range("Methode").Offset(i, 0).Row
Rem         Cible_Col = Range("Methode").Column
Rem         Call Scoring
Rem     End If
Rem Next i
Rem 
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBAFormModule
Sub UserForm1
Rem 
Rem Private Sub UserForm_Initialize()
Rem     OptionButton1 = True
Rem     With SpinButton1
Rem         .Min = 1 'Valeur mini
Rem         .Max = 5 'Valeur maxi
Rem         'Spécifie le déplacement se produisant lorsque l'utilisateur clique sur
Rem         'les flèches de défilement dans le contrôle SpinButton
Rem         '(La valeur par défaut = 1)
Rem         '.SmallChange = 1
Rem     End With
Rem     TextBox1 = 1
Rem End Sub
Rem 
Rem Private Sub SpinButton1_Change()
Rem     TextBox1 = SpinButton1.Value
Rem End Sub
Rem 
Rem Private Sub CommandButton1_Click()
Rem     Unload UserForm1
Rem     Nb_candidatures = TextBox1.Value
Rem     UserForm2.Show
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBAFormModule
Sub UserForm2
Rem Private Sub UserForm_Activate()
Rem 
Rem For i = 1 To Nb_candidatures
Rem     With UserForm2.Controls("Frame" & i)
Rem         .Top = 12 + 48 * (i - 1)
Rem     End With
Rem Next i
Rem For i = 1 To 2
Rem     UserForm2.Controls("CommandButton" & i).Top = 12 + 48 * Nb_candidatures
Rem Next i
Rem UserForm2.Height = 12 + 48 * (Nb_candidatures + 1)
Rem 
Rem If Nb_candidatures < 5 Then
Rem     For i = Nb_candidatures + 1 To 5
Rem         With UserForm2.Controls("Frame" & i)
Rem             .Top = 12 + 48 * i
Rem         End With
Rem         UserForm2.Controls("TextBox" & i).Value = ""
Rem     Next i
Rem End If
Rem End Sub
Rem 
Rem Private Sub CommandButton2_Click()
Rem     UserForm2.Hide
Rem     UserForm1.Show
Rem End Sub
Rem 
Rem Private Sub CommandButton1_Click()
Rem 
Rem Feuille_Scoring = ActiveSheet.Name
Rem 
Rem If Nb_candidatures > Range("Nb_ass") Then
Rem     Call Ajout_Col
Rem     Call MEF_Scoring1
Rem     Call MEF_Scoring2
Rem Else
Rem     Call Suppr_Col
Rem End If
Rem 
Rem For i = 1 To Nb_candidatures
Rem     Range("Ass1").Offset(0, i - 1) = UserForm2.Controls("TextBox" & i).Value
Rem Next i
Rem 
Rem Range("Nb_ass") = Nb_candidatures
Rem Unload UserForm2
Rem End Sub
Rem 
End Sub
 
Rem Attribute VBA_ModuleType=VBAModule
Sub Variables_Publiques
Rem Public Cible_Row As Integer
Rem Public Cible_Col As Integer
Rem Public Nb_candidatures As Integer
Rem Public Feuille_Scoring As String
Rem 
End Sub

**adou92150** · 13/03/2012, 18h36

Tu déchires !!!!!!!!!

Tu as fait une manip spéciale avec OO ? because j'avais essayé sans succès.

(tant pis pour les 2 pov userforms, ce qui m'importait surtout c'était de récupérer les 800 lignes de code pour pas me les retaper

)