Gestion de questions de quizz grâce à une macro
Bonjour,
Je souhaiterais faire des quizz (type QCM) grâce à un logiciel.
Pour créer mes questions et réponses (que je recopierais après sur le logiciel), j'utilise Exel.
Je souhaiterais gérer facilement la création de mes questions mais il me semble qu'il faille utiliser des macros, ce que je ne maîtrise pas bien....
Pour vous expliquer mon problème je vous joins aussi une copie de l'Excel.
Et pour être le plus clair possible :
Pour une même ligne(1 ligne = 1 question)
Colonne I à R : ce sont les propositions de réponses qui s'affichent sur le quizz de l'utilisateur ( il peut y en avoir maximum 10)
Colonne S à l'infini : Ce sont toutes les propositions de réponses possibles qui pourrait potentiellement être utilisé dans les colonnes I à R . Dans les colonnes S à l'infini, il y a des cellule avec une "*" au début. Ces cellules se mettent en blanc automatiquement et la police devient rouge. Les cellules avec les étoiles correspondent aux réponses bonnes.
Mon but est que dans les colonnes I à R soit copier (lorsque l'on lance la macro sur cette ligne) les réponses bonnes provenant des colonnes S à l'infini, puis que des mauvaises réponses soit copier dans les colonnes I à R une fois que toutes les bonnes réponses ai était copiées.
Exemple :
Dans la ligne 2 la question est "Quels sont les mots commençants par la lettre "M" ?
Dans la colonne S à l'infini il y a des propositions de réponses (dont les bonnes réponses avec l'* au début) :
- *Maman
- Natation
- Table
- Papa
- *Myrtille
- *Madagascar
- Natation
- Tableau
Du coup :
Colonne I, J et K , le mot "*Maman" dans la colonne I , "*Myrtille" dans la colonne J et "*Madagascar" dans la colonne K.
Puis au hasard parmi les réponses fausses et dans n'importe quel ordre :
Colonne L : Natation
Colonne M : Table
Colonne N : Papa
Colonne O : Tableau
Le deuxième "natation" n'a pas été rajoutée, car il est en doublon. Ceci est important.
Dans ce cas il y a moins deux 10 propositions dans les colonnes S à l'infini.
Mais si en plus des précédentes, il y aurait eu les mots :
- Voiture
- Vache
- Téléphone
- Table
- Avion
- Bateau
- Lit
Alors 3 autres propositions supplémentaires auraient était choisies pour arriver à un total de 10 propositions en tout.
Comment faire ça automatiquement , via une macro, dès que je sélectionne les 10 cellules des colonnes I à R d'une ligne et que j'active la macro par une touche raccourcie ?
Merci beaucoup !!:)
Gulli
Bonjour,
Une début de piste vite fait et à améliorer :
Sub QCM()
Dim Dico As Object
Dim PlgProp As Range
Dim PlgRep As Range
Dim I As Long
Dim L As Long
L = ActiveCell.Row
Set Dico = CreateObject("Scripting.Dictionary")
'plage définie sur la ligne de la cellule active contenant toutes les réponses à partir de la colonne "S"
With ActiveSheet: Set PlgRep = .Range(.Cells(L, 19), .Cells(L, .Columns.Count).End(xlToLeft)): End With
'plage définie sur la ligne de la cellule active recevant les réponses proposées (de "I" à "R")
With ActiveSheet: Set PlgProp = .Range(.Cells(L, 9), .Cells(L, 18)): End With
'initialise
Randomize
'boucle pour récupérer les réponses possibles aléatoires et éviter les doublons (Dico)
Do
I = CLng(Rnd() * PlgRep.Count + 1)
Dico(CStr(I)) = PlgRep(I).Value
Loop While Dico.Count <> PlgProp.Count
'colle dans la plage
PlgProp = Dico.Items
End Subje te propose une autre approche, dis moi ce qu tu en pense
pour l'instant le logiciel ne fonctionne que pour le mots commençant par la lettre "M", si ma proposition te convient tu me dis ce que tu souhaites, j'essaierai de continuer
tu peux modifier la liste des noms de la feuille, en mettre plus ou moins, il en faut au moins 10
a plus
Bonjour Theze et Guillaud ,
Tout d'abord merci beaucoup pour vos réponses, et désolé pour le retard de réponse de ma part j'étais pas mal occupé ces derniers jours.
Theze : Merci beaucoup, cette macro est exactement dans l'optique de celle que j'imaginais mise à par quelques détails que je vais énoncer.
Guillaud : Merci beaucoup, mais je ne souhaite pas faire de quizz directement sur l'Excel en lui m^me et je ne souhaite pas faire de quizz sur les "noms commençant pas des lettre", j'ai pris cette question comme exemple, mais mes questions n'auront aucun rapport avec ça.
Concernant la proposition de Thèse , voici mes questions/remarques :
1) J'aime beaucoup le fait que l'on peut lancer la macro ligne par ligne est non pas pour toute la feuille en même temps.
En effet, j'avais testé la formule : =INDEX($S$2:$XFD$2;ENT(ALEA()*NBVAL($S$2:$XFD$2)+1))
Mais un des gros soucis c'est que dès que je la copier dans une nouvelle ligne ça mettais à jour les autres.
2) Quand il y a moins de 10 "propositions" dans une ligne X, et que je lance la macro dans cette ligne X, Excel Bug.
3) Dans la ligne 2 (c'est là que j'ai vu le problème), parfois la macro génère une cellule vide.
4) Dans la sélection affichée dans les colonnes "Réponses", il y a aléatoirement des mots commençant par * et des mots ne commençant pas par *.
a) Dans le meilleur des cas, il faudrait que toutes les "bonnes" propositions (avec les *) soient mises automatiquement dans les premières réponses puis une fois "toutes les bonnes réponses affichées, que la macro prenne des propositions aléatoirement et sans doublon parmi les mauvaises propositions.
b) Si c'est impossible à faire, la deuxième solution serait qu'il y ait affiché dans les colonnes "réponses" uniquement des mauvaises réponses , c'est-à-dire sans *, et qu'aucune des réponses ne soit en doublon. Comme ça je remplace et copie-colle mes bonnes réponses à la main dans les premières de "réponses"
5) Ca serait la cerise sur le gâteau, mais voilà ma dernière question :
si il y a plus de 10 bonnes réponses dans les colonnes proposition d'une même ligne, alors est-il possible que dans la cellule "réponse 1" de cette même ligne soit écrit "TROP DE BONNES RÉPONSES" ?
Pensez -vous que cela est possible?
Merci beaucoup, et merci encore pour votre aide,
Bonne soirée
Gulli
Bonjour,
Teste ce code pour vois si il te convient :
Sub QCM()
Dim Dico As Object
Dim DicoSource As Object
Dim Elem
Dim PlgProp As Range
Dim PlgRep As Range
Dim I As Long
Dim L As Long
Dim Max As Integer
Dim J As Integer
Max = 3
Set Dico = CreateObject("Scripting.Dictionary")
Set DicoSource = CreateObject("Scripting.Dictionary")
L = ActiveCell.Row
'plage définie sur la ligne de la cellule active contenant toutes les réponses à partir de la colonne "S"
With ActiveSheet: Set PlgRep = .Range(.Cells(L, 19), .Cells(L, .Columns.Count).End(xlToLeft)): End With
'plage définie sur la ligne de la cellule active recevant les réponses proposées (de "I" à "R")
With ActiveSheet: Set PlgProp = .Range(.Cells(L, 9), .Cells(L, 18)): End With
'dédoublonne
For I = 1 To PlgRep.Count: DicoSource(PlgRep.Cells(1, I).Value) = PlgRep.Cells(1, I).Value: Next I
'récupère les valeurs sans doublons
Elem = DicoSource.Items
L = 0
'vérifie que le nombre maximum de bonne réponses demandé soit bien inférieur ou égal
'aux bonnes réponses présentent dans la liste de réponses
For I = 1 To PlgRep.Count
If Left(PlgRep(I).Value, 1) = "*" Then L = L + 1
Next I
If L < Max Then Max = L
'initialise
Randomize
'boucle pour récupérer les réponses possibles aléatoires et éviter les doublons (Dico)
Do
I = CInt(Rnd() * DicoSource.Count)
'ne pas dépasser le max moins 1
If I >= DicoSource.Count Then I = DicoSource.Count - 1
'stocke en premier les bonnes réponses
If J < Max Then
If Left(Elem(I), 1) = "*" Then
If Dico.exists(Elem(I)) = False Then
Dico.Add Elem(I), Elem(I)
J = J + 1
End If
End If
'puis complète
Else
If Dico.exists(Elem(I)) = False And Elem(I) <> "" Then
Dico.Add Elem(I), Elem(I)
End If
End If
Loop While Dico.Count < DicoSource.Count
'colle dans la plage
PlgProp.ClearContents
PlgProp = Dico.Items
End SubBonjour Theze,
Merci beaucoup pour ta réponse rapide.
Ça marche très bien
Cependant j'aurais d'autres questions :
Je joint le fichier pour faciliter la compréhension de mes questions
1) Est-il possible de remplacer les cellules "#N/A" par une cellule vide lorsqu'il y a moins de 10 propositions ?
2) Lorsque je lance la macro sur une ligne, j'ai l'impression que c'est uniquement les 3 premières cellules des colonnes propositions qui contiennent une *, après les mots avec une * sont disposé aléatoirement dans les colonnes "réponses".
Est-il possible de placer les mots avec une * en premiers ?
3) Lorsqu'il y a plus de 10 propositions bonnes (Exemple dans la deuxième question) , est-il possible de mettre toutes les cellules de la ligne des colonnes "Reponses" vide sauf la première cellule de ces colonnes ( la cellule I3 dans ce cas) où il y a marqué une phrase type, par exemple "Trop de bonnes réponses"
Merci beaucoup !
Bonne journée,
Gulli
Re,
1) Est-il possible de remplacer les cellules "#N/A" par une cellule vide lorsqu'il y a moins de 10 propositions ?
Il faut juste redimensionner la plage de réception (voir le nouveau code)
2) Lorsque je lance la macro sur une ligne, j'ai l'impression que c'est uniquement les 3 premières cellules des colonnes propositions qui contiennent une *, après les mots avec une * sont disposé aléatoirement dans les colonnes "réponses".
Est-il possible de placer les mots avec une * en premiers ?
Ok, dans ce cas, je ne prend plus en compte le nombre maximal de réponses vraies et un tri est effectué pour avoir les bonnes réponses en premier :
Sub QCM()
Dim Dico As Object
Dim DicoSource As Object
Dim Elem
Dim Tbl
Dim Tempo
Dim PlgProp As Range
Dim PlgRep As Range
Dim I As Long
Dim J As Integer
Set Dico = CreateObject("Scripting.Dictionary")
Set DicoSource = CreateObject("Scripting.Dictionary")
L = ActiveCell.Row
'plage définie sur la ligne de la cellule active contenant toutes les réponses à partir de la colonne "S"
With ActiveSheet: Set PlgRep = .Range(.Cells(L, 19), .Cells(L, .Columns.Count).End(xlToLeft)): End With
'plage définie sur la ligne de la cellule active recevant les réponses proposées (de "I" à "R")
With ActiveSheet: Set PlgProp = .Range(.Cells(L, 9), .Cells(L, 18)): End With
'dédoublonne
For I = 1 To PlgRep.Count: DicoSource(PlgRep.Cells(1, I).Value) = PlgRep.Cells(1, I).Value: Next I
'récupère les valeurs sans doublons
Elem = DicoSource.Items
'initialise
Randomize
'boucle pour récupérer les réponses possibles aléatoires
Do
I = CInt(Rnd() * DicoSource.Count)
If I > DicoSource.Count - 1 Then I = DicoSource.Count - 1
'stocke dans le dico
If Dico.exists(Elem(I)) = False Then Dico.Add Elem(I), Elem(I)
Loop While Dico.Count < DicoSource.Count
'tranfère dans un tableau pour le tri (bonnes réponses en premier)
Tbl = Dico.Items
'tri
For I = 0 To UBound(Tbl)
For J = I + 1 To UBound(Tbl)
If Left(Tbl(I), 1) <> "*" And Left(Tbl(J), 1) = "*" Then
Tempo = Tbl(J): Tbl(J) = Tbl(I): Tbl(I) = Tempo: Exit For
End If
Next J, I
'colle dans la plage
PlgProp.ClearContents
PlgProp.Resize(1, UBound(Tbl)) = Tbl
End SubBonjour,
Merci pour votre réponse !
Je me permet de relever un soucis un cette superbe Macro (encore merci
Je joins le fichier
Dans la ligne de la deuxième question du fichier joint, il y a un nombre important de mauvaise réponse , ce qui fait que le nombre total de propositions uniques et >10, par conséquent quand je lance la macro sur cette ligne, la macro écrit sur les cellule > à la colonne S et donc remplace des propositions.
Pareil pour la question 3.
Est-il possible de faire écrire par la macro maximum 10 cellules par ligne dans les colonnes "réponses"?
Merci beaucoup !
Bonne soirée,,
Gulli
Bonjour,
Effectivement, ceci m'avait échappé !
Voici avec la correction :
Sub QCM()
Dim Dico As Object
Dim DicoSource As Object
Dim Elem
Dim Tbl
Dim Tempo
Dim PlgProp As Range
Dim PlgRep As Range
Dim I As Long
Dim J As Integer
Set Dico = CreateObject("Scripting.Dictionary")
Set DicoSource = CreateObject("Scripting.Dictionary")
L = ActiveCell.Row
'plage définie sur la ligne de la cellule active contenant toutes les réponses à partir de la colonne "S"
With ActiveSheet: Set PlgRep = .Range(.Cells(L, 19), .Cells(L, .Columns.Count).End(xlToLeft)): End With
'plage définie sur la ligne de la cellule active recevant les réponses proposées (de "I" à "R")
With ActiveSheet: Set PlgProp = .Range(.Cells(L, 9), .Cells(L, 18)): End With
'dédoublonne
For I = 1 To PlgRep.Count: DicoSource(PlgRep.Cells(1, I).Value) = PlgRep.Cells(1, I).Value: Next I
'récupère les valeurs sans doublons
Elem = DicoSource.Items
'initialise
Randomize
'boucle pour récupérer les réponses possibles aléatoires
Do
I = CInt(Rnd() * DicoSource.Count)
If I > DicoSource.Count - 1 Then I = DicoSource.Count - 1
'stocke dans le dico
If Dico.exists(Elem(I)) = False Then Dico.Add Elem(I), Elem(I)
Loop While Dico.Count < DicoSource.Count
'tranfère dans un tableau pour le tri (bonnes réponses en premier)
Tbl = Dico.Items
'tri
For I = 0 To UBound(Tbl)
For J = I + 1 To UBound(Tbl)
If Left(Tbl(I), 1) <> "*" And Left(Tbl(J), 1) = "*" Then
Tempo = Tbl(J): Tbl(J) = Tbl(I): Tbl(I) = Tempo: Exit For
End If
Next J, I
'colle dans la plage
PlgProp.ClearContents
If UBound(Tbl) > 10 Then I = 10 Else I = UBound(Tbl)
PlgProp.Resize(1, I) = Tbl
End SubBonjour Theze !
Merci beaucoup pour votre réponse !
C'est parfait !
Petite question :
Si je met l'étoile (*) à la fin du mot au lieu du début, j'ai juste à remplacer ce code :
If Left(Tbl(I), 1) <> "*" And Left(Tbl(J), 1) = "*" Thenpar
If Right(Tbl(I), 1) <> "*" And Right(Tbl(J), 1) = "*" ThenC'est ça ?
Pour le moment cette macro correspond à ce que je peux faire avec mon projet.
Si j'ai d'autres compléments à rajouter dessus, je peux revenir directement vers toi via cette discussion ?
Merci beaucoup
Bonne soirée,
Gulli
Bonjour,
Si je met l'étoile (*) à la fin du mot au lieu du début, j'ai juste à remplacer ce code :
If Right(Tbl(I), 1) <> "*" And Right(Tbl(J), 1) = "*" Then
Tout à fait !
Si j'ai d'autres compléments à rajouter dessus, je peux revenir directement vers toi via cette discussion ?
Oui bien sûr !
Attention, je n'ai pas géré le fait que la ligne est vide ! Si ceci peut arriver, il te faut mettre en place un gestionnaire d'erreur.
Top !
Merci beaucoup.
À bientôt
Gulli
Bonjour Theze,
Je souhaiterais pouvoir compléter la macro par une action :
À chaque fois que je la lance sur la ligne , je souhaiterais que dans la colonne "Correct feedback" de cette soit écrit automatiquement est sous la forme de "Bullet point" les bonnes réponses, comme dans l'exemple envoyé.
Vous pensez que c'est possible ?
Merci d'avance pour votre réponse,
Bien à vous,
Gulliver
Bonsoir,
Les (*) sont à la fin des mots comme demandé dans le post précédant, si ça a à nouveau changé, adaptes :
Sub QCM()
Dim Dico As Object
Dim DicoSource As Object
Dim Elem
Dim Tbl
Dim Tempo
Dim PlgProp As Range
Dim PlgRep As Range
Dim I As Long
Dim J As Integer
Dim L As Long
Set Dico = CreateObject("Scripting.Dictionary")
Set DicoSource = CreateObject("Scripting.Dictionary")
L = ActiveCell.Row
'plage définie sur la ligne de la cellule active contenant toutes les réponses à partir de la colonne "S"
With ActiveSheet: Set PlgRep = .Range(.Cells(L, 19), .Cells(L, .Columns.Count).End(xlToLeft)): End With
'plage définie sur la ligne de la cellule active recevant les réponses proposées (de "I" à "R")
With ActiveSheet: Set PlgProp = .Range(.Cells(L, 9), .Cells(L, 18)): End With
'dédoublonne
For I = 1 To PlgRep.Count: DicoSource(PlgRep.Cells(1, I).Value) = PlgRep.Cells(1, I).Value: Next I
'récupère les valeurs sans doublons
Elem = DicoSource.Items
'initialise
Randomize
'boucle pour récupérer les réponses possibles aléatoires
Do
I = CInt(Rnd() * DicoSource.Count)
If I > DicoSource.Count - 1 Then I = DicoSource.Count - 1
'stocke dans le dico
If Dico.exists(Elem(I)) = False Then Dico.Add Elem(I), Elem(I)
Loop While Dico.Count < DicoSource.Count
'tranfère dans un tableau pour le tri (bonnes réponses en premier)
Tbl = Dico.Items
'tri
For I = 0 To UBound(Tbl)
For J = I + 1 To UBound(Tbl)
If Right(Tbl(I), 1) <> "*" And Right(Tbl(J), 1) = "*" Then
'If Left(Tbl(I), 1) <> "*" And Left(Tbl(J), 1) = "*" Then
Tempo = Tbl(J): Tbl(J) = Tbl(I): Tbl(I) = Tempo: Exit For
End If
Next J, I
'colle dans la plage
PlgProp.ClearContents
PlgProp.Resize(1, UBound(Tbl)) = Tbl
With ActiveSheet
'vide la cellule
.Cells(L, 3).Value = ""
For I = 0 To UBound(Tbl)
'seulement les mots finissant par une étoile
If Right(Tbl(I), 1) = "*" Then
'ajoute le caractère ¤ en gise de puce
.Cells(L, 3).Value = .Cells(L, 3).Value & "¤ " & Tbl(I) & vbCrLf
End If
Next I
'supprime le dernier retour à la ligne
.Cells(L, 3).Value = Left(.Cells(L, 3).Value, Len(.Cells(L, 3).Value) - 1)
End With
End SubBonsoir Theze !
Merci beaucoup
Est il possible de supprimer l'étoile (*) dans la colonne feed back ?
Merci beaucoup
Bonne soirée,
Gulli
Bonsoir Theze,
Lorsque je lance la nouvelle macro sur une ligne qui a plus de 10 propositions, il se crée plus le nombre de propositions qu'il y a est non maximum 10-n propositions avec n=le nombre de bonne réponse.
Vous pensez pouvoir voir ce que c'est ?
Merci beaucoup !
Gulli
Bonjour,
J'ai tellement modifié ce code que je ne sais plus trop où j'en suis
Regardes si c'est ce que tu cherches :
Sub QCM()
Dim Dico As Object
Dim DicoSource As Object
Dim Elem
Dim Tbl
Dim Tempo
Dim PlgProp As Range
Dim PlgRep As Range
Dim I As Long
Dim J As Integer
Dim L As Long
Set Dico = CreateObject("Scripting.Dictionary")
Set DicoSource = CreateObject("Scripting.Dictionary")
L = ActiveCell.Row
'plage définie sur la ligne de la cellule active contenant toutes les réponses à partir de la colonne "S"
With ActiveSheet: Set PlgRep = .Range(.Cells(L, 19), .Cells(L, .Columns.Count).End(xlToLeft)): End With
'plage définie sur la ligne de la cellule active recevant les réponses proposées (de "I" à "R")
With ActiveSheet: Set PlgProp = .Range(.Cells(L, 9), .Cells(L, 18)): End With
'dédoublonne
For I = 1 To PlgRep.Count: DicoSource(PlgRep.Cells(1, I).Value) = PlgRep.Cells(1, I).Value: Next I
'récupère les valeurs sans doublons
Elem = DicoSource.Items
'initialise
Randomize
'boucle pour récupérer les réponses possibles aléatoires
Do
I = CInt(Rnd() * DicoSource.Count)
If I > DicoSource.Count - 1 Then I = DicoSource.Count - 1
'stocke dans le dico
If Dico.exists(Elem(I)) = False Then Dico.Add Elem(I), Elem(I)
Loop While Dico.Count < DicoSource.Count
'tranfère dans un tableau pour le tri (bonnes réponses en premier)
Tbl = Dico.Items
'tri
For I = 0 To UBound(Tbl)
For J = I + 1 To UBound(Tbl)
If Left(Tbl(I), 1) <> "*" And Left(Tbl(J), 1) = "*" Then
Tempo = Tbl(J): Tbl(J) = Tbl(I): Tbl(I) = Tempo: Exit For
End If
Next J, I
'colle dans la plage
PlgProp.ClearContents
'pour ne pas dépasser le maximum de propositions possible dans la plage (actuellement 10 !)
If UBound(Tbl) > PlgProp.Count Then J = PlgProp.Count Else J = UBound(Tbl)
PlgProp.Resize(1, J) = Tbl
With ActiveSheet
'vide la cellule
.Cells(L, 3).Value = ""
For I = 0 To UBound(Tbl)
'seulement les mots commençant par une étoile
If Left(Tbl(I), 1) = "*" Then
'ajoute le caractère ¤ en gise de puce
.Cells(L, 3).Value = .Cells(L, 3).Value & "¤ " & Right(Tbl(I), Len(Tbl(I)) - 1) & vbCrLf
End If
Next I
'supprime le dernier retour à la ligne
.Cells(L, 3).Value = Left(.Cells(L, 3).Value, Len(.Cells(L, 3).Value) - 1)
End With
End SubTop
C'est parfait !
Merci beaucoup Theze ! You rock !
Bonne journée,
Gulli
Bonjour Thèze,
J'ai deux questions :
1) Par exemple lorsque je lance la macro lorsqu'il y a 3 propositions (Dont une bonne réponse), alors la macro insère la bonne réponse et une proposition est non deux.
Pareil si il y a une bonne réponse et 5 propositions fausses. La macro va insérer la proposition bonne et seulement 4 propositions fausses et ceux malgré le fait que le nombre de propositions totales soit <10
Est-il possible de changer ça ?
2) Supposons je sélectionne 100 lignes avec la souris, est il possible quand je lance la macro, d' exécuter la macro pour ces 100 lignes en une seule fois ?
Merci beaucoup
Bonne soirée,
Gulli
Bonsoir,
Pour ta première question, j'ai fais la bourde de partir sur une base 1 pour le tableau alors qu'il est en base 0 donc, ceci devrait le faire :
Sub QCM()
Dim Dico As Object
Dim DicoSource As Object
Dim Elem
Dim Tbl
Dim Tempo
Dim PlgProp As Range
Dim PlgRep As Range
Dim I As Long
Dim J As Integer
Dim L As Long
Set Dico = CreateObject("Scripting.Dictionary")
Set DicoSource = CreateObject("Scripting.Dictionary")
L = ActiveCell.Row
'plage définie sur la ligne de la cellule active contenant toutes les réponses à partir de la colonne "S"
With ActiveSheet: Set PlgRep = .Range(.Cells(L, 19), .Cells(L, .Columns.Count).End(xlToLeft)): End With
'plage définie sur la ligne de la cellule active recevant les réponses proposées (de "I" à "R")
With ActiveSheet: Set PlgProp = .Range(.Cells(L, 9), .Cells(L, 18)): End With
'dédoublonne
For I = 1 To PlgRep.Count: DicoSource(PlgRep.Cells(1, I).Value) = PlgRep.Cells(1, I).Value: Next I
'récupère les valeurs sans doublons
Elem = DicoSource.Items
'initialise
Randomize
'boucle pour récupérer les réponses possibles aléatoires
Do
I = CInt(Rnd() * DicoSource.Count)
If I > DicoSource.Count - 1 Then I = DicoSource.Count - 1
'stocke dans le dico
If Dico.exists(Elem(I)) = False Then Dico.Add Elem(I), Elem(I)
Loop While Dico.Count < DicoSource.Count
'tranfère dans un tableau pour le tri (bonnes réponses en premier)
Tbl = Dico.Items
'tri
For I = 0 To UBound(Tbl)
For J = I + 1 To UBound(Tbl)
If Left(Tbl(I), 1) <> "*" And Left(Tbl(J), 1) = "*" Then
Tempo = Tbl(J): Tbl(J) = Tbl(I): Tbl(I) = Tempo: Exit For
End If
Next J, I
'colle dans la plage
PlgProp.ClearContents
'pour ne pas dépasser le maximum de propositions possible dans la plage (actuellement 10 !)
'*******************Le tableau est en base 0 donc il faut en tenir compte !!!*********************
If UBound(Tbl) > PlgProp.Count - 1 Then J = PlgProp.Count Else J = UBound(Tbl) + 1
PlgProp.Resize(1, J) = Tbl
With ActiveSheet
'vide la cellule
.Cells(L, 3).Value = ""
For I = 0 To UBound(Tbl)
'seulement les mots commençant par une étoile
If Left(Tbl(I), 1) = "*" Then
'ajoute le caractère ¤ en gise de puce
.Cells(L, 3).Value = .Cells(L, 3).Value & "¤ " & Right(Tbl(I), Len(Tbl(I)) - 1) & vbCrLf
End If
Next I
'supprime le dernier retour à la ligne
.Cells(L, 3).Value = Left(.Cells(L, 3).Value, Len(.Cells(L, 3).Value) - 1)
End With
End SubPour ta seconde question, il suffit de sélectionner chaque cellule de la colonne A et d'appeler la proc QCM. Bon, la sélection je ne suis pas fan mais ça te permet de ne pas trop modifier le code et de pouvoir sélectionner manuellement une seule cellule si tu le désires :
Sub SelectionMultiple()
Dim I As Integer
Application.ScreenUpdating = False
For I = 2 To 101
Range("A" & I).Select
QCM
Next I
Application.ScreenUpdating = True
End Sub