Randon test generator based on some criteria

B

blelli

Board Regular
Joined
Jul 21, 2013
Messages
73
Hello guys,

I have an Excel Spreadsheet with a specific sheet called "DB" which contains 7 different fields:
Column A: Question
Column B: Alternative 1
Column C: Alternative 2
Column D: Alternative 3
Column E: Alternative 4
Column F: Difficult Level
Column G: Subject

And basically, we have more than 1000 different questions, distributed in 5 different difficulty levels and up to 50 different Subjects.

Now, my question is:
Given a specific number of questions, the distribution of difficulty of level and the necessary subjects, how can I elaborate an exam (test) with random questions and alternatives?

Example:
Let's suppose I'm looking for an exam (test) with 20 questions, containing the subjects Excel, Word and PowerPoint, and the exam's difficulty level distribution must be: 10% Very Difficult, 20% Difficult, 40% Normal, 20% Easy and 10% Very Easy.

So, in this case, we are looking for:
2 Very difficult questions,
4 Difficult questions,
8 Normal questions,
4 Easy questions, and
2 Very Easy questions

And the subject of those questions are:
Excel: 7 questions (roundUp)
Word: 7 questions (roundUp)
PowerPoint: 6 questions (the difference to the total)

How can I do that?
Any idea is very welcome!

Thanks
 
Sort by date Sort by votes
blelli said:
Wow!!! That was brilliant...
Click to expand...
blelli said:
That was amazing...
Click to expand...
blelli said:
Thanks for your kindly support...
Click to expand...
Appearing is not enough.

_______________________________________________________________________________________________________

blelli said:
How can I get the Alternatives in random order?
Click to expand...
blelli said:
Question 1.
Instead of having all subjects listed on different cells (like you did with Column "O"), my intention is to have a ListBox with all selected subjects...
Click to expand...
blelli said:
Question 2.
Instead of having the questions and alternatives on the same line, like:
Click to expand...
blelli said:
Question 3.
Is it possible to set some extra subjects that MUST HAVE ONLY 1 QUESTION?
Click to expand...
blelli said:
ve just added a new column on my Questions DB, called Correct Answer
Click to expand...
_______________________________________________________________________________________________________
I propose the following to you, because otherwise, this will be endless.
Analyze well what you want, prepare the design of the input data and how you want the output.
When you have a stable design, you come back here and show it.
And I will gladly help you to adapt the macro.
Be careful what I'm asking you for, only the input data and the output data.
The intermediate steps of how to do the solution are prepared by me.
 
Upvote 0

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
DanteAmor said:
Appearing is not enough.

_______________________________________________________________________________________________________






_______________________________________________________________________________________________________
I propose the following to you, because otherwise, this will be endless.
Analyze well what you want, prepare the design of the input data and how you want the output.
When you have a stable design, you come back here and show it.
And I will gladly help you to adapt the macro.
Be careful what I'm asking you for, only the input data and the output data.
The intermediate steps of how to do the solution are prepared by me.
Click to expand...
Thank you so much Mr. Dante!

I don't think it's fair to send all my requirements to you ... you are not working for me... you are just helping me, and you are doing an amazing job! I'm so glad and thankful for all your assistance...
So, please, allow me to send some other questions to you:

Some posts ago you helped me generating the alternatives in random order...
In my DataBase the correct answer is always the first alternative (Column B - "A1"), so how can I let the user know the correct answer once the alternatives were shuffled?
My intention is to add a new column at the end of your Questions Sheet on column AD for example, with the Correct Answer.

How can I do that?

Thank you so much!
 
Upvote 0
blelli said:
In my DataBase the correct answer is always the first alternative (Column B - "A1"),
My intention is to add a new column at the end of your Questions Sheet on column AD for example, with the Correct Answer.
Click to expand...
Then, the correct answer in column AJ

VBA Code: 
Sub RandomQuestions()
  Dim i As Long, j As Long, k As Long, x As Long, y As Long, n As Long
  Dim lr As Long, lr1 As Long, fila As Long, ii As Long
  Dim veces As Long, xsum As Double
  Dim arr As Variant, arr2 As Variant, b As Variant, c As Variant, e As Variant, g As Variant
  Dim f As Range
  Dim salir As Boolean
  Dim subj As String
  
  Application.ScreenUpdating = False
  
  'Sheets("DB").Select
  [R1] = [F1]
  [S1] = [G1]
  Range("Q2:AJ" & Rows.Count).ClearContents
  
  Randomize
  DoEvents
  
  'Validations
  If Range("I2").Value = "" Or Not IsNumeric(Range("I2").Value) Then
    MsgBox "Check Questions"
    Exit Sub
  End If
  
  If Range("K" & Rows.Count).End(3).Row <> Range("L" & Rows.Count).End(3).Row Then
    MsgBox "Check rows Level and Distribution"
    Exit Sub
  End If
  
  xsum = Application.Sum(Range("L2", Range("L" & Rows.Count).End(3)).Value)
  If Val(xsum) <> 1 Then
    MsgBox "Check 100% in distribution"
    Exit Sub
  End If
  
  lr1 = Range("K" & Rows.Count).End(3).Row
  With Range("M2:M" & lr1 - 1)
    .Formula = "=ROUND($I$2*L2,0)"
    .Value = .Value
  End With
  xsum = WorksheetFunction.Sum(Range("M2:M" & lr1 - 1).Value)
  If xsum <= Range("I2").Value Then
    Range("M" & lr1).Value = Range("I2").Value - xsum
  Else
    MsgBox "Check Distribution"
    Exit Sub
  End If
  
  lr1 = Range("O" & Rows.Count).End(3).Row
  With Range("P2:P" & lr1 - 1)
    .Formula = "=roundup($I$2/" & lr1 - 1 & ",0)"
    .Value = .Value
  End With
  xsum = WorksheetFunction.Sum(Range("P2:P" & lr1 - 1).Value)
  If xsum <= Range("I2").Value Then
    Range("P" & lr1).Value = Range("I2").Value - xsum
  Else
    MsgBox "Check Qty"
    Exit Sub
  End If
  Range("P:P").Copy
  Range("Q1").PasteSpecial xlPasteValues
  Application.CutCopyMode = False
  Range("AC1").Select

  b = Range("K2", Range("M" & Rows.Count).End(3)).Value
  c = Range("O2", Range("Q" & Rows.Count).End(3)).Value
  
  Range("S2").Resize(UBound(c)).Value = c
  For i = 1 To UBound(b)
    'if Difficult has value
    If b(i, 3) > 0 Then
      Range("R2").Resize(UBound(c)).Value = b(i, 1)
      Range("A1", Range("G" & Rows.Count).End(3)).AdvancedFilter xlFilterCopy, Range("R1:S" & UBound(c) + 1), Range("U1:AA1")
      
      lr = Range("U" & Rows.Count).End(3).Row - 1
      If lr > 1 Then
        If lr >= b(i, 3) Then
          If i = UBound(b) Then
            'i = i
            For ii = 2 To UBound(c) + 1
              If WorksheetFunction.CountIf(Range("AA:AA"), Range("O" & ii).Value) < Range("Q" & ii).Value Then
                MsgBox "Insufficient subjects for " & Range("O" & ii).Value & ". Try Again"
                Exit Sub
              End If
            Next
          End If
        
          arr = Evaluate("=ROW(1:" & lr & ")")
          veces = 0
          Do While True
            For j = 1 To b(i, 3)
              x = Int(UBound(arr) * Rnd + 1)
              y = arr(x, 1)
              arr(x, 1) = arr(j, 1)
              arr(j, 1) = y
            Next
            
            salir = True
            e = Range("Q2:Q" & UBound(c) + 1).Value
            For j = 1 To b(i, 3)
              fila = arr(j, 1) + 1
              subj = Range("AA" & fila)
              Set f = Range("O:O").Find(subj, , xlValues, xlWhole, , , False)
              If Not f Is Nothing Then
                If f.Offset(, 2).Value > 0 Then
                  f.Offset(, 2).Value = f.Offset(, 2).Value - 1
                Else
                  salir = False
                End If
              End If
            Next
            
            If salir = True Then
              Exit Do
            Else
              Range("Q2:Q" & UBound(c) + 1).Value = e
            End If
            veces = veces + 1
            If veces = 25 Then
              MsgBox "number of times exceeded. Check values and try again"
              Exit Sub
            End If
          Loop
          
          For j = 1 To b(i, 3)
            fila = arr(j, 1) + 1
            
            g = Application.Transpose(Range("V" & fila & ":Y" & fila).Value)
            arr2 = [ROW(1:4)]
            For k = 1 To UBound(arr2)
              x = Int(UBound(arr2) * Rnd + 1)
              y = arr2(x, 1)
              arr2(x, 1) = arr2(k, 1)
              arr2(k, 1) = y
            Next
            
            Range("AC" & Rows.Count).End(3)(2).Resize(1, 8).Value = _
              Array(Range("U" & fila), g(arr2(1, 1), 1), g(arr2(2, 1), 1), g(arr2(3, 1), 1), g(arr2(4, 1), 1), _
              Range("Z" & fila), Range("AA" & fila), Range("V" & fila))
          Next
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
DanteAmor said:
Then, the correct answer in column AJ

VBA Code: 
Sub RandomQuestions()
  Dim i As Long, j As Long, k As Long, x As Long, y As Long, n As Long
  Dim lr As Long, lr1 As Long, fila As Long, ii As Long
  Dim veces As Long, xsum As Double
  Dim arr As Variant, arr2 As Variant, b As Variant, c As Variant, e As Variant, g As Variant
  Dim f As Range
  Dim salir As Boolean
  Dim subj As String
 
  Application.ScreenUpdating = False
 
  'Sheets("DB").Select
  [R1] = [F1]
  [S1] = [G1]
  Range("Q2:AJ" & Rows.Count).ClearContents
 
  Randomize
  DoEvents
 
  'Validations
  If Range("I2").Value = "" Or Not IsNumeric(Range("I2").Value) Then
    MsgBox "Check Questions"
    Exit Sub
  End If
 
  If Range("K" & Rows.Count).End(3).Row <> Range("L" & Rows.Count).End(3).Row Then
    MsgBox "Check rows Level and Distribution"
    Exit Sub
  End If
 
  xsum = Application.Sum(Range("L2", Range("L" & Rows.Count).End(3)).Value)
  If Val(xsum) <> 1 Then
    MsgBox "Check 100% in distribution"
    Exit Sub
  End If
 
  lr1 = Range("K" & Rows.Count).End(3).Row
  With Range("M2:M" & lr1 - 1)
    .Formula = "=ROUND($I$2*L2,0)"
    .Value = .Value
  End With
  xsum = WorksheetFunction.Sum(Range("M2:M" & lr1 - 1).Value)
  If xsum <= Range("I2").Value Then
    Range("M" & lr1).Value = Range("I2").Value - xsum
  Else
    MsgBox "Check Distribution"
    Exit Sub
  End If
 
  lr1 = Range("O" & Rows.Count).End(3).Row
  With Range("P2:P" & lr1 - 1)
    .Formula = "=roundup($I$2/" & lr1 - 1 & ",0)"
    .Value = .Value
  End With
  xsum = WorksheetFunction.Sum(Range("P2:P" & lr1 - 1).Value)
  If xsum <= Range("I2").Value Then
    Range("P" & lr1).Value = Range("I2").Value - xsum
  Else
    MsgBox "Check Qty"
    Exit Sub
  End If
  Range("P:P").Copy
  Range("Q1").PasteSpecial xlPasteValues
  Application.CutCopyMode = False
  Range("AC1").Select

  b = Range("K2", Range("M" & Rows.Count).End(3)).Value
  c = Range("O2", Range("Q" & Rows.Count).End(3)).Value
 
  Range("S2").Resize(UBound(c)).Value = c
  For i = 1 To UBound(b)
    'if Difficult has value
    If b(i, 3) > 0 Then
      Range("R2").Resize(UBound(c)).Value = b(i, 1)
      Range("A1", Range("G" & Rows.Count).End(3)).AdvancedFilter xlFilterCopy, Range("R1:S" & UBound(c) + 1), Range("U1:AA1")
     
      lr = Range("U" & Rows.Count).End(3).Row - 1
      If lr > 1 Then
        If lr >= b(i, 3) Then
          If i = UBound(b) Then
            'i = i
            For ii = 2 To UBound(c) + 1
              If WorksheetFunction.CountIf(Range("AA:AA"), Range("O" & ii).Value) < Range("Q" & ii).Value Then
                MsgBox "Insufficient subjects for " & Range("O" & ii).Value & ". Try Again"
                Exit Sub
              End If
            Next
          End If
       
          arr = Evaluate("=ROW(1:" & lr & ")")
          veces = 0
          Do While True
            For j = 1 To b(i, 3)
              x = Int(UBound(arr) * Rnd + 1)
              y = arr(x, 1)
              arr(x, 1) = arr(j, 1)
              arr(j, 1) = y
            Next
           
            salir = True
            e = Range("Q2:Q" & UBound(c) + 1).Value
            For j = 1 To b(i, 3)
              fila = arr(j, 1) + 1
              subj = Range("AA" & fila)
              Set f = Range("O:O").Find(subj, , xlValues, xlWhole, , , False)
              If Not f Is Nothing Then
                If f.Offset(, 2).Value > 0 Then
                  f.Offset(, 2).Value = f.Offset(, 2).Value - 1
                Else
                  salir = False
                End If
              End If
            Next
           
            If salir = True Then
              Exit Do
            Else
              Range("Q2:Q" & UBound(c) + 1).Value = e
            End If
            veces = veces + 1
            If veces = 25 Then
              MsgBox "number of times exceeded. Check values and try again"
              Exit Sub
            End If
          Loop
         
          For j = 1 To b(i, 3)
            fila = arr(j, 1) + 1
           
            g = Application.Transpose(Range("V" & fila & ":Y" & fila).Value)
            arr2 = [ROW(1:4)]
            For k = 1 To UBound(arr2)
              x = Int(UBound(arr2) * Rnd + 1)
              y = arr2(x, 1)
              arr2(x, 1) = arr2(k, 1)
              arr2(k, 1) = y
            Next
           
            Range("AC" & Rows.Count).End(3)(2).Resize(1, 8).Value = _
              Array(Range("U" & fila), g(arr2(1, 1), 1), g(arr2(2, 1), 1), g(arr2(3, 1), 1), g(arr2(4, 1), 1), _
              Range("Z" & fila), Range("AA" & fila), Range("V" & fila))
          Next
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub
Click to expand...

Thank you so much Mr. Dante!

I've another question...

Even with lots of questions (+1000 questions for the same subject for example), if I choose only 1, 2, 3, or 4 subjects for example (when trying to create a questionnaire with 20 questions), the system is showing the following MsgBox: Insufficient subjects for xxx. Try again.

I strongly believe that it's related to the Difficulty Levels, because if the user select 5 or more subjects, it works perfectly.

How can I solve this issue?

The system should generate questionnaires no matter the number of subjects selected...

Thank you!
 
Upvote 0
blelli said:
The system should generate questionnaires no matter the number of subjects selected...
Click to expand...
This random "system" is very complex.
I explain to you.

Suppose the following scenario:
3 difficult
3 easy
Subjects:
2 excel
2 word
2 power
If your database has
excel easy
excel easy
excel difficult
Word easy
word easy
word difficult
power easy
power easy
power difficult

In theory in the database you have the elements to generate the questionnaire.
If the "system" chooses:
word easy
word easy
You can no longer choose Word Difficult. Because the requirement is 2 word. So you can't choose 3 word.
And there are only 2 Difficult available.
Then the questionnaire cannot be completed.

Hope you understand the problem facing the "system".
I tried to find the possible solutions. But maybe more code is needed to avoid inconsistencies like above.
Then it won't be so random anymore. I think so.

It would help if you are going to choose 3 questions, but at your base you have 50.
When you choose a number of questions very close to the limit of your database, you will have these problems.
Increase your number of questions in database and choose fewer questions of a subject and of a difficulty.
I hope you understand what I mean, in my example, you are choosing 3 difficult ones and in the database there are only 3.
So if you choose 3 but in the database you have 100, then the probability of running out of subjects will be minimal.
 
Upvote 0
DanteAmor said:
This random "system" is very complex.
I explain to you.

Suppose the following scenario:
3 difficult
3 easy
Subjects:
2 excel
2 word
2 power
If your database has
excel easy
excel easy
excel difficult
Word easy
word easy
word difficult
power easy
power easy
power difficult

In theory in the database you have the elements to generate the questionnaire.
If the "system" chooses:
word easy
word easy
You can no longer choose Word Difficult. Because the requirement is 2 word. So you can't choose 3 word.
And there are only 2 Difficult available.
Then the questionnaire cannot be completed.

Hope you understand the problem facing the "system".
I tried to find the possible solutions. But maybe more code is needed to avoid inconsistencies like above.
Then it won't be so random anymore. I think so.

It would help if you are going to choose 3 questions, but at your base you have 50.
When you choose a number of questions very close to the limit of your database, you will have these problems.
Increase your number of questions in database and choose fewer questions of a subject and of a difficulty.
I hope you understand what I mean, in my example, you are choosing 3 difficult ones and in the database there are only 3.
So if you choose 3 but in the database you have 100, then the probability of running out of subjects will be minimal.
Click to expand...

I understand... and I'll have to find a solution for this issue...
Please, check the following example:

I have 74 Different questions about Word, being:
Very Easy: 16
Easy: 16
Medium: 19
Difficult: 12
Very Difficult: 11

So, basically, I have enough questions to generate a 10 questions questionnaire...
But the system is saying "Check Qty"

So, I can't understand
 
Upvote 0
Maybe if you change the conditions of the difficulty.
That is, if instead of writing:
3 difficult
3 easy.
subject
2excel
2word
2power

You write something like this:
1excel-difficult
1excel-easy
1word-difficult
1word-easy
1power-hard
1power-easy
That way the "system" will not enter the ambiguity that I showed you in post #15. And as long as there is enough quantity in the database, it will generate the questionnaire.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
Excel for Practice Exam
Replies
4
Views
310
Logit
Logit
P
  • Question Question
VBA to perform Text Diff (but with >2500 Char per cell)
Replies
0
Views
260
potatoooooooo
P
B
  • Question Question
VBA to edit/update cells within a large table from a common "Dashboard"
Replies
1
Views
470
brianv
B
S
  • Question Question
Creating a random sequence of items from a weighted list with no duplicates
Replies
6
Views
216
shg
shg
MarkSELA
  • Question Question
Multiple choice question generator using randomly selected Excel ranges
Replies
3
Views
340
MarkSELA
MarkSELA

Forum statistics

Threads
1,223,879
Messages
6,175,145
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top