Randon test generator based on some criteria

[blelli]

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

 

[DanteAmor]

Hi blelli, I show you an option.

First, structure your sheet as follows:

varios 24nov2019 randomize.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
1	Question	A1	A2	A3	A4	Difficult Level	Subject		Questions		Difficult Level	Ditribution	Result		Subject	Qty	Qty	Difficult Level	Subject		Question	A1	A2	A3	A4	Difficult Level	Subject		Question Result	Difficult Level	Subject
2	q1					Very Difficult	Excel		20		Very Difficult	10%	2		Excel	7	0	Very Easy	Excel		q5					Very Easy	Excel		q50	Very Difficult	PowerPoint
3	q2					Difficult	Excel				Difficult	20%	4		Word	7	0	Very Easy	Word		q10					Very Easy	Excel		q45	Very Difficult	Word
4	q3					Normal	Excel				Normal	40%	8		PowerPoint	6	0	Very Easy	PowerPoint		q15					Very Easy	Word		q46	Difficult	Word
5	q4					Easy	Excel				Easy	20%	4								q20					Very Easy	PowerPoint		q12	Difficult	Word
6	q5					Very Easy	Excel				Very Easy	10%	2								q34					Very Easy	Excel		q2	Difficult	Excel
7	q6					Very Difficult	Excel														q39					Very Easy	Excel		q41	Difficult	Word
8	q7					Difficult	Excel														q44					Very Easy	Word		q42	Normal	Word
9	q8					Normal	Excel														q49					Very Easy	PowerPoint		q3	Normal	Excel
10	q9					Easy	Excel																						q18	Normal	Word
11	q10					Very Easy	Excel																						q47	Normal	Word
12	q11					Very Difficult	Word																						q52	Normal	PowerPoint
13	q12					Difficult	Word																						q23	Normal	PowerPoint
14	q13					Normal	Word																						q8	Normal	Excel
15	q14					Easy	Word																						q32	Normal	Excel
16	q15					Very Easy	Word																						q4	Easy	Excel
17	q16					Very Difficult	Word																						q38	Easy	Excel
18	q17					Difficult	Word																						q53	Easy	PowerPoint
19	q18					Normal	Word																						q48	Easy	PowerPoint
20	q19					Easy	PowerPoint																						q20	Very Easy	PowerPoint
21	q20					Very Easy	PowerPoint																						q10	Very Easy	Excel
22	q21					Very Difficult	PowerPoint
23	q22					Difficult	PowerPoint
24	q23					Normal	PowerPoint
25	q24					Easy	PowerPoint
26	q25					Very Difficult	Other
27	q26					Difficult	Other
28	q27					Normal	Other
29	q28					Easy	Other
30	q29					Very Easy	Other
Questions

The columns marked in green are the ones that you must fill, all the other columns are calculated by the macro.
The result will be in columns AC and AD.

Try the following macro, I tried to put the most basic validations, but when dealing with random values, it is possible in some attempt, the data is finished. For example if you need 5 subject excel, but you only have 4, then the macro ends.

Sub RandomQuestions()
  Dim i As Long, j 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, b As Variant, c As Variant, e As Variant
  Dim f As Range
  Dim salir As Boolean
  Dim subj As String
  
  Application.ScreenUpdating = False
  
  'Sheets("Questions").Select
  [R1] = [F1]
  [S1] = [G1]
  Range("Q2:AE" & 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
            Range("AC" & Rows.Count).End(3)(2).Resize(1, 3).Value = Array(Range("U" & fila), Range("Z" & fila), Range("AA" & fila))
          Next
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[Akuini]

how can I elaborate an exam (test) with random questions and alternatives?

by alternatives you mean alternative question?
so there are questions in col A:E?
let's say the code pick row 2, then do you want the code to pick randomly which question?

 

[blelli]

Hi blelli, I show you an option.

First, structure your sheet as follows:

varios 24nov2019 randomize.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
1	Question	A1	A2	A3	A4	Difficult Level	Subject		Questions		Difficult Level	Ditribution	Result		Subject	Qty	Qty	Difficult Level	Subject		Question	A1	A2	A3	A4	Difficult Level	Subject		Question Result	Difficult Level	Subject
2	q1					Very Difficult	Excel		20		Very Difficult	10%	2		Excel	7	0	Very Easy	Excel		q5					Very Easy	Excel		q50	Very Difficult	PowerPoint
3	q2					Difficult	Excel				Difficult	20%	4		Word	7	0	Very Easy	Word		q10					Very Easy	Excel		q45	Very Difficult	Word
4	q3					Normal	Excel				Normal	40%	8		PowerPoint	6	0	Very Easy	PowerPoint		q15					Very Easy	Word		q46	Difficult	Word
5	q4					Easy	Excel				Easy	20%	4								q20					Very Easy	PowerPoint		q12	Difficult	Word
6	q5					Very Easy	Excel				Very Easy	10%	2								q34					Very Easy	Excel		q2	Difficult	Excel
7	q6					Very Difficult	Excel														q39					Very Easy	Excel		q41	Difficult	Word
8	q7					Difficult	Excel														q44					Very Easy	Word		q42	Normal	Word
9	q8					Normal	Excel														q49					Very Easy	PowerPoint		q3	Normal	Excel
10	q9					Easy	Excel																						q18	Normal	Word
11	q10					Very Easy	Excel																						q47	Normal	Word
12	q11					Very Difficult	Word																						q52	Normal	PowerPoint
13	q12					Difficult	Word																						q23	Normal	PowerPoint
14	q13					Normal	Word																						q8	Normal	Excel
15	q14					Easy	Word																						q32	Normal	Excel
16	q15					Very Easy	Word																						q4	Easy	Excel
17	q16					Very Difficult	Word																						q38	Easy	Excel
18	q17					Difficult	Word																						q53	Easy	PowerPoint
19	q18					Normal	Word																						q48	Easy	PowerPoint
20	q19					Easy	PowerPoint																						q20	Very Easy	PowerPoint
21	q20					Very Easy	PowerPoint																						q10	Very Easy	Excel
22	q21					Very Difficult	PowerPoint
23	q22					Difficult	PowerPoint
24	q23					Normal	PowerPoint
25	q24					Easy	PowerPoint
26	q25					Very Difficult	Other
27	q26					Difficult	Other
28	q27					Normal	Other
29	q28					Easy	Other
30	q29					Very Easy	Other
Questions

The columns marked in green are the ones that you must fill, all the other columns are calculated by the macro.
The result will be in columns AC and AD.

Try the following macro, I tried to put the most basic validations, but when dealing with random values, it is possible in some attempt, the data is finished. For example if you need 5 subject excel, but you only have 4, then the macro ends.

Sub RandomQuestions()
  Dim i As Long, j 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, b As Variant, c As Variant, e As Variant
  Dim f As Range
  Dim salir As Boolean
  Dim subj As String
 
  Application.ScreenUpdating = False
 
  'Sheets("Questions").Select
  [R1] = [F1]
  [S1] = [G1]
  Range("Q2:AE" & 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
            Range("AC" & Rows.Count).End(3)(2).Resize(1, 3).Value = Array(Range("U" & fila), Range("Z" & fila), Range("AA" & fila))
          Next
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Wow!!! That was brilliant...

Would you mind providing an example with the alternatives in random order?
In your previous example, the outputs are Question, Difficult and Subject... but there is no alternatives!

How can I get the Alternatives in random order?

Let's suppose the question is: "What day is today?", and the alternatives are: "08/14/2021", "09/14/2021", "10/14/2021" and "11/14/2021". The correct answer is: "08/14/2021".

I would like to show something like this:
What day is today?
10/14/2021
09/14/2021
11/14/2021
08/14/2021

And if this question was elected again, the alternatives would be randomly generated again... like:
What day is today?
09/14/2021
10/14/2021
11/14/2021
08/14/2021

How can I do that?

 

[DanteAmor]

Wow!!! That was brilliant...

Happy to hear that

Would you mind providing an example with the alternatives in random order?

Of course, here is the updated code.
The result will be in columns AC and AI.

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("Questions").Select
  [R1] = [F1]
  [S1] = [G1]
  Range("Q2:AI" & 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, 7).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))
          Next
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[blelli]

Happy to hear that


Of course, here is the updated code.
The result will be in columns AC and AI.

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("Questions").Select
  [R1] = [F1]
  [S1] = [G1]
  Range("Q2:AI" & 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, 7).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))
          Next
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Thank you so much!

That was amazing...

Would you mind answering some other questions?
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...
How can I adapt your code to collect the desired subjects from a ListBox, instead of different cells, like you did with column "O"?
Basically, my intention is to have two different ListBoxs. The ListBox1 would contain all available subjects and ListBox2 with only the subjects selected by the user...

Question 2.
Instead of having the questions and alternatives on the same line, like:
Column A, Column B, Column C, Column D,Column E
Question 1, Alternative 1, Alternative 2, Alternative 3, Alternative 4

How can I adapt your code in order to have questions and alternatives on different lines, like:
Line 1: Question 1
Line 2: Alternative 1
Line 3: Alternative 2
Line 4: Alternative 3
Line 5: Alternative 4
Line 6: <Empty line>

Question 3.
Is it possible to set some extra subjects that MUST HAVE ONLY 1 QUESTION?
Example: Let's suppose you said that you want 20 Questions, being 10% Very Easy, 20% Easy, 40% Normal, 20% Difficult and 10% Very Difficult, and you also said that the necessary subjects are Word, Excel and PowerPoint... And now, this questionnaire MUST HAVE 1 QUESTION about PHOTOSHOP, and 1 QUESTION about PAINT.

So, in this case, the questionnaire must have:
1 Question about Photoshop
1 Question about Paint
18 Questions about all the other necessary subjects...


I'm sorry for asking lots of questions to you.
I'm really learning from your methodology!

Thank you so much!
You are the best...

 

[DanteAmor]

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...
How can I adapt your code to collect the desired subjects from a ListBox,

The best thing would be to pass the data from the listbox to cells O2 down. With something like this:

Range("O2").Resize(ListBox2.ListCount, 1).Value = ListBox2.List

And then you run the code.

_____________________________________________________

Question 2. Instead of having the questions and alternatives on the same line, like:
Column A, Column B, Column C, Column D,Column E

I do not understand that. Your initial requirement is:

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.

Where are you going to put the difficulty and the subject?
If you have 1000 questions, then now you will have 6000 lines?
I do not understand what do you need.

 

[DanteAmor]

Question 3.
Is it possible to set some extra subjects that MUST HAVE ONLY 1 QUESTION?
Example: Let's suppose you said that you want 20 Questions, being 10% Very Easy, 20% Easy, 40% Normal, 20% Difficult and 10% Very Difficult, and you also said that the necessary subjects are Word, Excel and PowerPoint... And now, this questionnaire MUST HAVE 1 QUESTION about PHOTOSHOP, and 1 QUESTION about PAINT.

So, in this case, the questionnaire must have:
1 Question about Photoshop
1 Question about Paint
18 Questions about all the other necessary subjects...

I think you could solve that, from the final result, delete 2 questions at random; and add 1 from Photoshop and another from Paint

 

[blelli]

I think you could solve that, from the final result, delete 2 questions at random; and add 1 from Photoshop and another from Paint

Thanks for your kindly support...

I'm trying to adapt your code, but I'm getting the following error:
Error 1004 "Application-defined or Object-defined error"

On this section of your code:

Range("A1", Range("H" & Rows.Count).End(3)).AdvancedFilter xlFilterCopy, Range("S1:T" & UBound(c) + 1), Range("V1:AC1")

How can I solve it?
I've just added a new column on my Questions DB, called Correct Answer, and it's between the Alternative4 and the Difficult Level, as you can see below:

Question

Alt1

Alt2

Alt3

Alt4

Correct Answer

Difficult Level

Subject

Please, find all my code below:

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("Questions").Select
  [R1] = [F1]
  [S1] = [G1]
  'Range("Q2:AI" & Rows.Count).ClearContents
 
  Randomize
  DoEvents
 
  'Validations
  If Range("J2").Value = "" Or Not IsNumeric(Range("J2").Value) Then
    MsgBox "Check Questions"
    Exit Sub
  End If
 
  If Range("L" & Rows.Count).End(3).Row <> Range("M" & Rows.Count).End(3).Row Then
    MsgBox "Check rows Level and Distribution"
    Exit Sub
  End If
 
  xsum = Application.Sum(Range("M2", Range("M" & Rows.Count).End(3)).Value)
  If Val(xsum) <> 1 Then
    MsgBox "Check 100% in distribution"
    Exit Sub
  End If
 
  lr1 = Range("L" & Rows.Count).End(3).Row
  With Range("N2:N" & lr1 - 1)
    .Formula = "=ROUND($J$2*M2,0)"
    .Value = .Value
  End With
  xsum = WorksheetFunction.Sum(Range("N2:N" & lr1 - 1).Value)
  If xsum <= Range("J2").Value Then
    Range("N" & lr1).Value = Range("J2").Value - xsum
  Else
    MsgBox "Check Distribution"
    Exit Sub
  End If
 
  lr1 = Range("P" & Rows.Count).End(3).Row
  With Range("Q2:Q" & lr1 - 1)
    .Formula = "=roundup($J$2/" & lr1 - 1 & ",0)"
    .Value = .Value
  End With
  xsum = WorksheetFunction.Sum(Range("Q2:Q" & lr1 - 1).Value)
  If xsum <= Range("J2").Value Then
    Range("Q" & lr1).Value = Range("J2").Value - xsum
  Else
    MsgBox "Check Qty"
    Exit Sub
  End If
  Range("Q:Q").Copy
  Range("R1").PasteSpecial xlPasteValues
  Application.CutCopyMode = False
  Range("AD1").Select

  b = Range("L2", Range("N" & Rows.Count).End(3)).Value
  c = Range("P2", Range("R" & Rows.Count).End(3)).Value
 
  Range("T2").Resize(UBound(c)).Value = c
  For i = 1 To UBound(b)
    'if Difficult has value
    If b(i, 3) > 0 Then
      Range("S2").Resize(UBound(c)).Value = b(i, 1)
      Range("A1", Range("H" & Rows.Count).End(3)).AdvancedFilter xlFilterCopy, Range("S1:T" & UBound(c) + 1), Range("V1:AC1")
     
      lr = Range("V" & 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("AB:AB"), Range("P" & ii).Value) < Range("R" & ii).Value Then
                MsgBox "Insufficient subjects for " & Range("P" & 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("R2:R" & UBound(c) + 1).Value
            For j = 1 To b(i, 3)
              fila = arr(j, 1) + 1
              subj = Range("AB" & fila)
              Set f = Range("P:P").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("R2:R" & 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("W" & fila & ":Z" & 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("AD" & Rows.Count).End(3)(2).Resize(1, 7).Value = _
              Array(Range("V" & fila), g(arr2(1, 1), 1), g(arr2(2, 1), 1), g(arr2(3, 1), 1), g(arr2(4, 1), 1), _
              Range("AA" & fila), Range("AB" & fila))
          Next
        End If
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Once again,
Thank you!

 

[DanteAmor]

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

If you are not going to respect the structure of your initial post, with 7 columns, then the macro will not work.
It is a very complex macro, one of the most complicated that I have ever done.
Any change, no matter how simple it may seem to you, requires a complete analysis of the entire macro, and as I already explained, it is a very complex macro.
So, to know how you have the "new" structure, it is not enough for me, if you say: I want a new column. I need to see an image or a sample of your data, for that use the XL2BB tool minisheet.