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
| Global nbre_question As Integer 'nombre de questions indiqué dans la feuille questionnaire
Global nbre_total_question As Integer 'nombre total de questions existantes
Dim comp As Integer 'indique si la question est deja presente dans le questionnaire
Dim dern_ligne As Long 'derniere cellule remplis du questionnaire
Dim l_verif As Integer 'variable s'incrementant pour la verification des lignes
Dim Chaine_Recherch As String 'variable contenant la prochaine question qui va etre ecrite (apres vérification)
Dim Ligne_Recherch As Integer 'variable contenant le numero de la ligne de la prochaine question qui va etre ecrite
Dim nbre_rep As Integer 'nombre de reponses possibles pour la prochaine question
Dim colonne_repA As Integer 'numero de colonne reponse A a ecrire
Dim ligne_cop As Integer 'numero de ligne du debut de la copie
Dim espace As Integer 'espace entre questions
Dim t As Integer 'boucle for question
Dim r As Integer 'boucle for reponse
Dim height_cell As Double 'hauteur de ligne avant cellule
Dim height_cell_dest As Double 'hauteur de cellule de destination
Dim height_chbx As Double 'hauteur de la checkbox
Dim width_chbx As Double 'largeur de la checkbox
Dim posX_chbx As Double 'position x checkbox
Dim posY_chbx As Double 'position y checkbox
Dim name_reps_ok As String
Dim tab_Quest
'fonction permettant d'obtenir le nombre de caractere "x" d'une cellule
Function nbstr(car, cellule)
Dim compt 'compteur nombre de caractere
Dim n As Integer
compt = 0 'RAZ compteur nombre de caractere
'boucle pour compter les caracteres présents
For n = 1 To Len(cellule.Value)
If Mid$(cellule, n, 1) = car Then compt = compt + 1
Next
nbstr = compt
End Function
Sub question() 'procedure pour ecrire les questions
nbre_question = Sheets("Questionnaire").Range("k2")
nbre_total_question = Sheets("Questionnaire").Range("k4")
colonne_repA = 4
espace = 2
If Sheets("Questionnaire").Range("B" & Rows.Count).End(xlUp).Row > Sheets("Questionnaire").Range("A" & Rows.Count).End(xlUp).Row Then
dern_ligne = Sheets("Questionnaire").Range("B" & Rows.Count).End(xlUp).Row
Else
dern_ligne = Sheets("Questionnaire").Range("A" & Rows.Count).End(xlUp).Row
End If
ligne_cop = 1
Sheets("Questionnaire").Range(Cells(2, 1), Cells(dern_ligne, 2)).ClearContents 'raz questionnaire precedent
Sheets("Questionnaire").CheckBoxes.Delete
If nbre_question > nbre_total_question Then 'vérification du nombre de questions
MsgBox "nombre de questions trop grand"
Sheets("Questionnaire").Range("k2").ClearContents
Exit Sub
End If
For t = 1 To nbre_question 'Ecriture des Questions/reponses jusqu'au nombre de question voulus
ReDim tab_Quest(t)
ligne_cop = ligne_cop + 1 + espace
l_verif = 0
Ligne_Recherch = Int(Rnd * nbre_total_question) + 1
'tab_Quest()(t)(0) = Sheets("questions").Cells(Ligne_Recherch + 1, 1)
Chaine_Recherch = Sheets("questions").Cells(Ligne_Recherch + 1, 1)
Do While l_verif < ligne_cop + t + 1 'boucle pour determiner si la question a deja été écrite
'comparaison de la question nouvellement ecrite avec les questions précedentes
If Chaine_Recherch.Value = tab_Quest()(l_verif)(0).Value Then
l_verif = 0
'copie d'une autre question si deja presente
Ligne_Recherch = Int(Rnd * nbre_total_question) + 1
Chaine_Recherch = Sheets("questions").Cells(Ligne_Recherch + 1, 1).Value
Else
l_verif = l_verif + 1
End If
Loop
'copie de la question dans un questionnaire
'copie de la question à la suite du questionnaire
Sheets("Questionnaire").Cells(ligne_cop, 1).Value = Chaine_Recherch
Sheets("Questionnaire").Cells(ligne_cop, 2).Value = "bonne reponse: " & Sheets("questions").Cells(Ligne_Recherch + 1, 3).Value
'nombre de reponses possibles
nbre_rep = Sheets("questions").Cells(Ligne_Recherch + 1, 2).Value
'boucle de copie des reponses possibles
For r = 1 To nbre_rep
'ajout des checkbox + texte reponse
height_cell = Range(Cells(1, 1), Cells(Sheets("Questionnaire").Cells(ligne_cop + r, 2).Row, 1)).Height 'hauteur de ligne avant cellule
height_chbx = 10 'hauteur de la checkbox
height_cell_dest = Sheets("Questionnaire").Cells(ligne_cop + r, 2).Height
'calcul position x checkbox
posX_chbx = Range("k7") 'width_cell - (0.4 * width_cell_dest) + width_chbx '- (1.2 * width_chbx)
'calcul position y checkbox
posY_chbx = height_cell - height_cell_dest '- (1.5 * height_chbx
'nom des bonnes réponses
name_reps_ok = 1
'ajout de la checkbox (add (x,y,larg,haut)) et de la reponse
Sheets("Questionnaire").CheckBoxes.Add(posX_chbx, posY_chbx, width_chbx, height_chbx).Select
Selection.Characters.Text = Sheets("questions").Cells(Ligne_Recherch + 1, colonne_repA + r - 1)
Selection.Name = "Q" & Ligne_Recherch & "Rep" & r
Selection.Width = 500
Next
'mise a jour ligne de debut de copie
ligne_cop = ligne_cop + nbre_rep
Next
End Sub |
Partager