Génération de la correction d'un questionnaire

Version imprimable

Bonjour,
J'ai généré un questionnaire à partir d'un tableau avec des questions et des réponses. Le but était de générer des questions aléatoires. J'ai ensuite programmé une macro pour surligner en vert les réponses correctes dans le tableau. A présent, je suis en train de programmer la correction des checkboxes.
Le nombre de réponses varie suivant les questions. Pour l’instant, j'essaye de seulement programmer la réponse de la question 1. Voilà mon code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 Sub correction_du_questionnaire() Dim intitule_question As String Dim tout_juste As Boolean Dim nb_de_points As Integer 'Sélection de la question intitule_question = Range("A1").Value 'Recherche de cette question dans le tableau de la feuille 1 Set q = Sheets("feuil1").Range("A:A").Find(intitule_question) 'On en déduit le numéro de la question numero_question = q.Row - 1 'Détermination du nombre de réponses nb_reponses = Sheets("feuil1").Cells(numero_question + 1, 2) 'Mise en place du flag pour les réponses justes tout_juste = True While tout_juste = True tout_juste = False 'Boucle de vérification des réponses For i = 1 To nb_reponses Sheets("feuil2").Shapes("Q" & numero_question & "Rep" & i).Select If (Selection.Value = True And Sheets("feuil1").Cells(numero_question + 1, i + 3).Interior.Color = RGB(0, 255, 0)) Or (Selection.Value = False And Sheets("feuil1").Cells(numero_question + 1, i + 3).Interior.Color = RGB(255, 255, 255)) Then tout_juste = True End If Next Wend 'Calcul des points If tout_juste = True Then nb_de_points = 2 Else: nb_de_points = -1 End If 'Affichage des points Range("H4").Value = nb_de_points End Sub
Les bonnes réponses de la question 1 sont les réponses 1 et 4. Même lorsque je les coche, le nombre de points affiché est toujours -1. J'avais programmé pour que ces checkboxes s'appellent Q1Rep1, Q1Rep2, Q1Rep3, Q1Rep4 et Q1Rep5. Pouvez-vous m'aider ? Merci !

12/04/2014, 17h34
casefayere
J'ai survolé ton code mais dès le départ, je me pose des questions, rien qu'ici
Code:

1 2 3 4 5 6 7 ... intitule_question = Range("A1").Value 'Recherche de cette question dans le tableau de la feuille 1 Set q = Sheets("feuil1").Range("A:A").Find(intitule_question) ...
si range("A1") est sur la même feuille que range("A:A"), précises le ou utilises les "With"

Je pense qu'il serait bien que tu fournisses un fichier (traduit en Xls ou compressé en Zip, par exemple) afin d'essayer de suivre ton raisonnement.

Bon courage
12/04/2014, 17h41
benjamin_malaussene

1 pièce(s) jointe(s)

Merci de ta réponse Dom, voilà mon fichier !
12/04/2014, 17h48
casefayere

tu dois avoir un problème avec ton fichier car, dès que je l'ouvre, Excel se ferme. On va essayer de faire autrement :
1- tu colles ici tous tes codes (attention aux balises)
2- si ton questionnaire est sur un USF, exportes-le et envoies le
3- envoies ton fichier en xlsx

1 pièce(s) jointe(s)

Voici tout mon code depuis le début :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
Sub generer_questions()
 
Dim plage_questions As Range
Dim tirage As Integer, nb_questions As Integer, questions_possibles As Integer, nb_reponses As Integer, fin_du_questionnaire As Integer
Dim question As String
Dim Cbx As OLEObject
Dim L As Integer, T As Integer
 
'Nombre de questions du questionnaire
nb_questions = Sheets("feuil2").Range("H1").Value
 
'Nombre de questions possibles
questions_possibles = Sheets("feuil2").Range("H2").Value
 
'Etablissement de la plage des questions
Set plage_questions = Sheets("feuil2").Range("A1:A1000")
 
L = 110
T = Range("A1").Height
 
'Au début le questionnaire commence à la ligne 1
fin_du_questionnaire = 1
 
Randomize
 
'Boucle de généréation des questions aléatoires
For i = 0 To nb_questions - 1
 
    'Tirage au sort d'un chiffre entre 1 et les questions possibles
    Do
        tirage = Int((questions_possibles * Rnd) + 1)
 
        'Sélection de la question correspondant au tirage
        question = WorksheetFunction.Index(Sheets("feuil1").Range("A2:A100"), tirage)
 
        'Vérification que la question n'existe pas déjà
    Loop Until Application.CountIf(plage_questions, question) = 0
 
    'Affichage de la question
    Cells(fin_du_questionnaire, 1) = question
 
    nb_reponses = Sheets("feuil1").Cells(tirage + 1, 2)
 
        'Génération des check boxes
        For j = 1 To nb_reponses
            Sheets("feuil2").CheckBoxes.Add(Left:=L, Top:=T, Width:=130, Height:=16).Select
            Selection.Characters.Text = Sheets("feuil1").Cells(tirage + 1, j + 3)
            Selection.Name = "Q" & tirage & "Rep" & j
 
             T = T + Range("A1").Height
        Next
 
    'Pour la question suivante, il faut sauter un nombres de lignes correspondant au nombre de réponses
    fin_du_questionnaire = fin_du_questionnaire + nb_reponses + 1
    T = fin_du_questionnaire * Range("A1").Height
 
Next
 
End Sub
 
Sub bonnes_reponses_en_vert()
 
Dim BR, bonnes_reponses As Integer
 
For i = 0 To 99
BR = Split(Sheets("feuil1").Cells(2 + i, 3), ",", -1)
nb_bonnes_reponses = UBound(BR)
 
    For j = 0 To nb_bonnes_reponses
        Sheets("feuil1").Cells(2 + i, BR(j) + 3).Interior.Color = RGB(0, 255, 0)
    Next
Next
 
End Sub
 
Sub correction_du_questionnaire()
 
Dim intitule_question As String
Dim tout_juste As Boolean
Dim nb_de_points As Integer
 
'Sélection de la question
intitule_question = Sheets("feuil1").Range("A1").Value
 
'Recherche de cette question dans le tableau de la feuille 1
Set q = Sheets("feuil1").Range("A:A").Find(intitule_question)
 
'On en déduit le numéro de la question
numero_question = q.Row - 1
 
'Détermination du nombre de réponses
nb_reponses = Sheets("feuil1").Cells(numero_question + 1, 2)
 
'Mise en place du flag pour les réponses justes
tout_juste = True
 
While tout_juste = True
    tout_juste = False
 
    'Boucle de vérification des réponses
    For i = 1 To nb_reponses
        Sheets("feuil2").Shapes("Q" & numero_question & "Rep" & i).Select
        If (Selection.Value = True And Sheets("feuil1").Cells(numero_question + 1, i + 3).Interior.Color = RGB(0, 255, 0)) Or (Selection.Value = False And Sheets("feuil1").Cells(numero_question + 1, i + 3).Interior.Color = RGB(255, 255, 255)) Then
        tout_juste = True
        End If
    Next
Wend
 
'Calcul des points
If tout_juste = True Then
nb_de_points = 2
Else: nb_de_points = -1
End If
 
'Affichage des points
Range("H4").Value = nb_de_points
 
End Sub

Je te renvoie le fichier, converti de la bonne façon cette fois.

12/04/2014, 18h08
benjamin_malaussene

1 pièce(s) jointe(s)

Le voici en xlsx.

Je réponds juste à ton problème actuel car, apparemment, il y a du boulot sur le reste. Voici ce que j'ai testé

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub correction_du_questionnaire()
 
Dim intitule_question As String
Dim tout_juste As Boolean
Dim nb_de_points As Integer, DerLg As Range, i As Integer
Dim Cb As CheckBox, Q As Range
 
'Sélection de la question
With Sheets("feuil1")
  intitule_question = Sheets("feuil2").Range("A1").Value
  Set DerLg = .Range("A" & .Rows.Count).End(xlUp)
 
  'Recherche de cette question dans le tableau de la feuille 1
  Set Q = .Range("A1", DerLg).Find(intitule_question)
  If Not Q Is Nothing Then
    numero_question = Q.Row
  Else: MsgBox "non trouvé": Exit Sub
  End If
 
  'Détermination du nombre de réponses
  nb_reponses = .Cells(numero_question, 2)
 
'Boucle sur les checkboxes formulaires de la Feuil1
  For Each Cb In Feuil2.CheckBoxes
    If Cb.Value = xlOn And (Sheets("feuil1").Cells(numero_question, i + 3).Interior.Color _
    = RGB(255, 255, 255)) Or (Selection.Value = False And Sheets("feuil1").Cells(numero_question, i + 3).Interior.Color = RGB(255, 255, 255)) Then
      nb_de_points = 2
    Else: nb_de_points = -1
    End If
  Next Cb
End With
 
'Affichage des points
Range("H4").Value = nb_de_points
 
End Sub

j'ai oublié une boucle

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub correction_du_questionnaire()
 
Dim intitule_question As String
Dim tout_juste As Boolean
Dim nb_de_points As Integer, DerLg As Range, i As Integer
Dim Cb As CheckBox, Q As Range, x As Integer
 
'Sélection de la question
With Sheets("feuil1")
  intitule_question = Sheets("feuil2").Range("A1").Value
  Set DerLg = .Range("A" & .Rows.Count).End(xlUp)
 
  'Recherche de cette question dans le tableau de la feuille 1
  Set Q = .Range("A1", DerLg).Find(intitule_question)
  If Not Q Is Nothing Then
    numero_question = Q.Row
  Else: MsgBox "non trouvé": Exit Sub
  End If
 
  'Détermination du nombre de réponses
  nb_reponses = .Cells(numero_question, 2)
  nb_de_points = 0: x = 1
  'Boucle sur les checkboxes formulaires de la Feuil1
  For Each Cb In Feuil2.CheckBoxes
    For i = 4 To 13
      If Cb = xlOn And (Sheets("feuil1").Cells(numero_question, i).Interior.Color _
        = 65280) Or (Selection.Value = False And Sheets("feuil1").Cells(numero_question, i).Interior.Color = 65280) Then
        nb_de_points = nb_de_points + 2
      Else: nb_de_points = nb_de_points - 1
      End If
    Next i
    x = x + 1
  Next Cb
End With
 
'Affichage des points
Range("H4").Value = nb_de_points
End Sub

peut-être encore à corriger

12/04/2014, 19h50
benjamin_malaussene

Salut dom, merci de ta réponse, mais il ya plusieurs choses que je ne comprends pas :

Code:

Set DerLg = .Range("A" & .Rows.Count).End(xlUp)

A quoi sert cette ligne ? Que signifie rows.count ?

Code:

If Not Q Is Nothing Then

Que signifie "not Q" ?

Ton code fonctionne pour une seule question, merci beaucoup, maintenant je dois le modifier pour toutes les questions.
12/04/2014, 19h58
casefayere
j'esprère que tu as vu mes dernières corrections sur "Interior.Color" et je ne sais pas si le numero de couleur correspond chez toi, pour faire le test, cliques sur une cellule colorée en feuil1 et lances ce code
Code:

1 2 3 4 Sub asupprimer() MsgBox Selection.Interior.Color End Sub
Citation:

Envoyé par Armays

Salut dom, merci de ta réponse, mais il ya plusieurs choses que je ne comprends pas :
- Set DerLg = .Range("A" & .Rows.Count).End(xlUp)
A quoi sert cette ligne ? Que signifie rows.count ?

- If Not Q Is Nothing Then
Que signifie "not Q" ?

Ton code fonctionne pour une seule question, merci beaucoup, maintenant je dois le modifier pour toutes les questions.

Code:

Set DerLg = .Range("A" & .Rows.Count).End(xlUp)

te donne dans une variable "Range" la dernière cellule utilisée

Code:

If Not Q Is Nothing

'sert pour vérifier la fonction "Find", est-ce que la recherche a été fructueuse, c'est juste une sécurité supplémentaire
N'hésites pas à te servir de l'aide !!!

1 pièce(s) jointe(s)

Bonjour,

J'ai réussi à programmer la correction dans les cas suivants :
- Si toutes les réponses d'une question sont justes, alors la question vaut 2 points
- S'il y a une erreur ou plus dans les réponses, la question vaut -1 point.

Mais maintenant, je voudrais ajouter le cas où rien n'est coché dans une question, dans ce cas la question vaut 0 point.

Voici mon code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
Dim nb_questions As Integer
 
Static Sub generer_questions()
 
Dim plage_questions As Range
Dim tirage As Integer, questions_possibles As Integer, nb_reponses As Integer, fin_du_questionnaire As Integer, bonnes_reponses As Integer
Dim question As String
Dim Cbx As OLEObject
Dim L As Integer, T As Integer
 
'raz questionnaire precedent
Sheets("feuil2").Range("A:A").ClearContents
Sheets("feuil2").Range("D:D").ClearContents
Sheets("feuil2").CheckBoxes.Delete
 
'Nombre de questions du questionnaire
nb_questions = Sheets("feuil2").Range("H1").Value
 
'Nombre de questions possibles
questions_possibles = Sheets("feuil2").Range("H2").Value
 
'Messages d'erreur si le nombre de questions est trop important
If nb_questions > 99 Then
MsgBox "Le nombre de questions est supérieur au nombre total de questions disponibles"
 
ElseIf nb_questions > questions_possibles Then
MsgBox "Le nombre de questions doit être inférieur au nombre de questions possibles"
 
End If
 
'Etablissement de la plage des questions
Set plage_questions = Sheets("feuil2").Range("A1:A1000")
 
L = 110
T = 2 * Range("A1").Height
 
'Au début le questionnaire commence à la ligne 2
fin_du_questionnaire = 2
 
Randomize
 
'Boucle de généréation des questions aléatoires
For i = 0 To nb_questions - 1
 
    'Tirage au sort d'un chiffre entre 1 et les questions possibles
    Do
        tirage = Int((questions_possibles * Rnd) + 1)
 
        'Sélection de la question correspondant au tirage
        question = WorksheetFunction.Index(Sheets("feuil1").Range("A2:A100"), tirage)
 
        'Vérification que la question n'existe pas déjà
    Loop Until Application.CountIf(plage_questions, question) = 0
 
    'Affichage de la question
    Cells(fin_du_questionnaire, 1) = question
 
    nb_reponses = Sheets("feuil1").Cells(tirage + 1, 2)
 
        'Génération des check boxes
        For j = 1 To nb_reponses
            Sheets("feuil2").CheckBoxes.Add(Left:=L, Top:=T, Width:=130, Height:=16).Select
            Selection.Characters.Text = Sheets("feuil1").Cells(tirage + 1, j + 3)
            Selection.Name = "Q" & tirage & "Rep" & j
 
             T = T + Range("A1").Height
        Next
 
    'Pour la question suivante, il faut sauter un nombres de lignes correspondant au nombre de réponses
    fin_du_questionnaire = fin_du_questionnaire + nb_reponses + 1
    T = fin_du_questionnaire * Range("A1").Height
 
Next
 
End Sub
 
Sub bonnes_reponses_en_vert()
 
Dim BR As Integer
 
For i = 0 To 99
BR = Split(Sheets("feuil1").Cells(2 + i, 3), ",", -1)
nb_bonnes_reponses = UBound(BR)
 
    For j = 0 To nb_bonnes_reponses
        Sheets("feuil1").Cells(2 + i, BR(j) + 3).Interior.Color = RGB(0, 255, 0)
    Next
Next
 
End Sub
 
Sub correction_du_questionnaire()
 
Dim intitule_question As String, nom_checkbox As String, numeros_reponses As String
Dim tout_juste As Boolean
Dim nb_de_points As Integer, ligne_questionnaire As Integer
Dim couleur_reponse As Long
 
'On fixe la ligne du questionnaire à 1
ligne_questionnaire = 1
 
'Le nombre de points est à 0
nb_de_points = 0
 
'On détermine le nombre de questions
nb_questions = Sheets("feuil2").Range("H1").Value
 
For i = 1 To nb_questions
    'Détermination de la ligne de la prochaine question
    ligne_questionnaire = Sheets("feuil2").Cells(ligne_questionnaire, 1).End(xlDown).Row
 
    'Sélection de la question
    intitule_question = Sheets("feuil2").Cells(ligne_questionnaire, 1).Value
 
    'Recherche de cette question dans le tableau de la feuille 1
    Set q = Sheets("feuil1").Range("A:A").Find(intitule_question)
 
    'On en déduit le numéro de la question
    numero_question = q.Row - 1
 
    'Détermination du nombre de réponses
    nb_reponses = Sheets("feuil1").Cells(numero_question + 1, 2)
 
    'Affichage des bonnes réponses
    numeros_reponses = Sheets("feuil1").Cells(numero_question + 1, 3).Value
    Cells(ligne_questionnaire, 4) = "bonnes_reponses : " & numeros_reponses
 
    'Mise en place du flag pour les réponses justes
    tout_juste = False
 
    'Boucle de vérification des réponses
    For j = 1 To nb_reponses
        nom_checkbox = "Q" & numero_question & "Rep" & j
        couleur_reponse = Sheets("feuil1").Cells(numero_question + 1, j + 3).Interior.Color
        Sheets("feuil2").Shapes(nom_checkbox).Select
 
        If (Selection.Value = 1 And couleur_reponse = 65280) Or (Selection.Value = -4146 And couleur_reponse = 16777215) Then
        tout_juste = True
        Else:
        tout_juste = False
        Exit For
        End If
    Next
 
    'Calcul des points
    If tout_juste = True Then
    nb_de_points = nb_de_points + 2
    Else: nb_de_points = nb_de_points - 1
    End If
Next
 
'Affichage des points
Range("H4").Value = nb_de_points
 
End Sub

Je transmets également le fichier, merci !

Bonjour,

Tu n'as pas adapté ma proposition.

Citation:

Mais maintenant, je voudrais ajouter le cas où rien n'est coché dans une question, dans ce cas la question vaut 0 point.

Je te l'ai suggéré, la condition ne marche que si "Cb = XlOn"
Code:

1 2 3 4 ... If Cb = xlOn And (Sheets("feuil1").Cells(numero_question, i).Interior.Color _ = 65280) Or (Selection.Value = False And Sheets("feuil1").Cells(numero_question, i).Interior.Color = 65280) Then ...

Bonjour Dom,

Je suis désolée mais je n'ai pas réussi à comprendre ton code. J'ai trouvé une solution, j'ai rajouté une boucle avec un autre flag pour le cas où aucune réponse n'est cochée :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Sub correction_du_questionnaire()
 
Dim intitule_question As String, nom_checkbox As String, numeros_reponses As String
Dim tout_juste As Boolean, rien_coche As Boolean
Dim nb_de_points As Integer, ligne_questionnaire As Integer
Dim couleur_reponse As Long
 
'On fixe la ligne du questionnaire à 1
ligne_questionnaire = 1
 
'Le nombre de points est à 0
nb_de_points = 0
 
'On détermine le nombre de questions
nb_questions = Sheets("feuil2").Range("H1").Value
 
For i = 1 To nb_questions
    'Détermination de la ligne de la prochaine question
    ligne_questionnaire = Sheets("feuil2").Cells(ligne_questionnaire, 1).End(xlDown).Row
 
    'Sélection de la question
    intitule_question = Sheets("feuil2").Cells(ligne_questionnaire, 1).Value
 
    'Recherche de cette question dans le tableau de la feuille 1
    Set q = Sheets("feuil1").Range("A:A").Find(intitule_question)
 
    'On en déduit le numéro de la question
    numero_question = q.Row - 1
 
    'Détermination du nombre de réponses
    nb_reponses = Sheets("feuil1").Cells(numero_question + 1, 2)
 
    'Affichage des bonnes réponses
    numeros_reponses = Sheets("feuil1").Cells(numero_question + 1, 3).Value
    Cells(ligne_questionnaire, 4) = "bonnes_reponses : " & numeros_reponses
 
    'Mise en place du flag pour les réponses justes
    tout_juste = False
    rien_coche = False
 
    'Boucle de vérification des réponses pour le cas où tout est juste
    For j = 1 To nb_reponses
        nom_checkbox = "Q" & numero_question & "Rep" & j
        couleur_reponse = Sheets("feuil1").Cells(numero_question + 1, j + 3).Interior.Color
        Sheets("feuil2").Shapes(nom_checkbox).Select
 
        If (Selection.Value = 1 And couleur_reponse = 65280) Or (Selection.Value = -4146 And couleur_reponse = 16777215) Then
        tout_juste = True
        Else:
        tout_juste = False
        Exit For
        End If
    Next
 
    'Boucle de vérification des réponses pour le cas où rien n'est coché
    For k = 1 To nb_reponses
        nom_checkbox = "Q" & numero_question & "Rep" & k
        Sheets("feuil2").Shapes(nom_checkbox).Select
        If Selection.Value = -4146 Then
        rien_coche = True
        Else:
        rien_coche = False
        Exit For
        End If
    Next
 
    'Calcul des points
    If tout_juste = True Then
    nb_de_points = nb_de_points + 2
    ElseIf rien_coche = True Then
    nb_de_points = nb_de_points
    Else: nb_de_points = nb_de_points - 1
    End If
Next
 
'Affichage des points
Range("H4").Value = nb_de_points
 
End Sub

14/04/2014, 10h33
casefayere

Dommage mais, enfin si ça fonctionne !

Si tu veux progresser, fais l'effort, à tête reposée et en t'aidant de tous les outils disponibles : l'aide(F1), le forum, internet, documentations..., de comprendre ce qui est proposé car je le répète, il y a du boulot même dans tes autres procédures, perso je serai parti sur un Usf mais c'est toi que ça regarde.

Bon courage

Bonjour,

J'ai modifié ta macro pour obtenir les réponses directement dans une collection!

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
Public TbReponse() As String
Public CollecReponse As Collection
Dim nb_questions As Integer
 
 Sub testCorrection()
 Dim i As Long
 For i = 1 To UBound(TbReponse)
   MsgBox CollecReponse(Sheets("feuil2").Range(TbReponse(i)))
 Next
 
 End Sub

Static Sub generer_questions()
ReDim TbReponse(0)
Set CollecReponse = Nothing
Set CollecReponse = New Collection
Dim TxtReponse As String
Dim plage_questions As Range
Dim tirage As Integer, questions_possibles As Integer, nb_reponses As Integer, fin_du_questionnaire As Integer, bonnes_reponses As Integer
Dim question As Range
Dim Cbx As OLEObject
Dim L As Integer, T As Integer
 Dim IndexReponse As Long
'raz questionnaire precedent
Sheets("feuil2").Range("A:A").ClearContents
Sheets("feuil2").Range("D:D").ClearContents
Sheets("feuil2").CheckBoxes.Delete
 
'Nombre de questions du questionnaire
nb_questions = Sheets("feuil2").Range("H1").Value
 
'Nombre de questions possibles
questions_possibles = Sheets("feuil2").Range("H2").Value
 
'Messages d'erreur si le nombre de questions est trop important
If nb_questions > 99 Then
MsgBox "Le nombre de questions est supérieur au nombre total de questions disponibles"
 
ElseIf nb_questions > questions_possibles Then
MsgBox "Le nombre de questions doit être inférieur au nombre de questions possibles"
 
End If
 
'Etablissement de la plage des questions
Set plage_questions = Sheets("feuil2").Range("A1:A1000")
 
L = 110
T = 2 * Range("A1").Height
 
'Au début le questionnaire commence à la ligne 2
fin_du_questionnaire = 2
 
Randomize
 
'Boucle de généréation des questions aléatoires
For i = 0 To nb_questions - 1
 
    'Tirage au sort d'un chiffre entre 1 et les questions possibles
    Do
        tirage = Int((questions_possibles * Rnd) + 1)
 
        'Sélection de la question correspondant au tirage
       Set question = WorksheetFunction.Index(Sheets("feuil1").Range("A2:A100"), tirage)
 
        'Vérification que la question n'existe pas déjà
    Loop Until Application.CountIf(plage_questions, question) = 0
 
    'Affichage de la question
    Cells(fin_du_questionnaire, 1) = question
   IndexReponse = IndexReponse + 1
 ReDim Preserve TbReponse(IndexReponse)
 TbReponse(IndexReponse) = Cells(fin_du_questionnaire, 1).Address
    nb_reponses = Sheets("feuil1").Cells(tirage + 1, 2)
 
        'Génération des check boxes
        TxtReponse = ""
        For j = 1 To nb_reponses
            Sheets("feuil2").CheckBoxes.Add(Left:=L, Top:=T, Width:=130, Height:=16).Select
            Selection.Characters.Text = Sheets("feuil1").Cells(tirage + 1, j + 3)
            Selection.Name = "Q" & tirage & "Rep" & j
            If Sheets("feuil1").Cells(tirage + 1, j + 3).Interior.Color = 65280 Then TxtReponse = TxtReponse & Sheets("feuil1").Cells(tirage + 1, j + 3) & ";"
 
             T = T + Range("A1").Height
        Next
        CollecReponse.Add TxtReponse, Sheets("feuil1").Range(TbReponse(IndexReponse))
 
    'Pour la question suivante, il faut sauter un nombres de lignes correspondant au nombre de réponses
    fin_du_questionnaire = fin_du_questionnaire + nb_reponses + 1
    T = fin_du_questionnaire * Range("A1").Height
 
Next
 
End Sub