Random Number Generator To Auto-Generate an Exam/Test

[DushiPunda]

Hello,
I currently have a spreadsheet which contains 2 worksheets:
1. Question Bank
2. Random Selection

On Question Bank, I am using Columns A, B, and C, in the following format:

#	Question	Answer
1	Question 1	Answer 1
..	..	..
150	Question 150	Answer 150

<tbody>
</tbody>

On Random Selection, I am also using Columns A, B, and C, in the following format:

Rnd

#

Selected Question

<tbody>
</tbody>

Starting on Row 3:

Column A:

{=RandomSelection('Question Bank'!A2:A149)}

Column B is just hard coded 1-X.

Column C:

=VLOOKUP(A3,'Question Bank'!$A$2:$B$149,2,FALSE)

My UDF, RandomSelection:

Option Explicit

Function RandomSelection(aRng As Range)
    Dim myTarg As Range, _
        SrcList, Rslt(), _
        i As Long, j As Long, k As Long
    Application.Volatile    'Force recalculation (new selection of random data) even if data doesn't change
    SrcList = aRng.Value
    Set myTarg = Application.Caller
    Randomize
    With myTarg
        If .Areas.count > 1 Then
             RandomSelection = _
                 "Function can be used only in a single contiguous range"
            Exit Function   '<<<<<
        End If
        If .Rows.count > 1 And .Columns.count > 1 Then
            RandomSelection = _
                "Selected cells must be in a single row or column"
            Exit Function   '<<<<<
        End If
        If .Cells.count > aRng.Cells.count Then
            RandomSelection = _
                "Range specified as argument must contain more cells than output selection"
            Exit Function   '<<<<<
        End If
        ReDim Rslt(1 To IIf(.Rows.count > 1, .Rows.count, .Columns.count))
    End With
    
    j = UBound(SrcList, 1)
    For i = LBound(Rslt) To UBound(Rslt)
        k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
        Rslt(i) = SrcList(k, 1)
        SrcList(k, 1) = SrcList(j, 1)
        j = j - 1
    Next i
    
    If myTarg.Rows.count > 1 Then
        RandomSelection = Application.WorksheetFunction.Transpose(Rslt)
    Else
        RandomSelection = Rslt
    End If
End Function

So, this was used at a previous job for the same reason I want to use it at my current job: to generate a random test. However, I'd like to implement one thing and I'm not too sure how to accomplish it:

I will be using this to generate a monthly test and I'd like to prevent questions from showing up in sequential months. As an example, if question 136 is used on May's monthly test, I don't want it to populate on another test until, say, August. So, when I'm generating the test for June & July, if the result of the UDF is 136, it should recalculate.

Just brainstorming ideas, I figured I could just add a helper column (say, Column D) on my Question Bank sheet where the value of the cell would be the numerical value of the month that question was last selected. And then, in subsequent months - if the result of the UDF refers to a question who's value in Column D is within the 3 of the numerical value of the current month, discard and try again (if Month(Date) - D.Value <= 2 then discard/try again).

But the problem is, I didn't write the code for this function and so I'm having a little trouble figuring out how exactly to implement this function.

Any help is greatly appreciated. Thanks!

 

[DushiPunda]

So, just doing some trial and error testing, specifically with this block of code:

    j = UBound(SrcList, 1)
    For i = LBound(Rslt) To UBound(Rslt)
        k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
        Rslt(i) = SrcList(k, 1)
        SrcList(k, 1) = SrcList(j, 1)
        j = j - 1
    Next i

I tried changing it to this:

    j = UBound(SrcList, 1)
    For i = LBound(Rslt) To UBound(Rslt)
        k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
        If Month(Date) - Worksheets("Question Bank").Cells(k + 1, 4).Value <= 2 Then
            i = i - 1
        Else
            Rslt(i) = SrcList(k, 1)
            SrcList(k, 1) = SrcList(j, 1)
            j = j - 1
            Worksheets("Question Bank").Cells(k + 1, 4).Value = Month(Date)
        End If
    Next i

My thought process is this: if the result of my If statement is true, then i = i - 1, and then the next line of code (because the If was true, thus we skip the code contained in the else), should be "Next i"...And because we subtracted one from i, it should repeat for whatever the original value of i was. However, when I do this, I get a #VALUE! error.

I added some MsgBox's just to see what the values of everything is:

    j = UBound(SrcList, 1)
    For i = LBound(Rslt) To UBound(Rslt)
        k = Int(Rnd() * (j - LBound(SrcList, 1) + 1)) + LBound(SrcList, 1)
        If i < 5 Then 'Just so I don't receive the MsgBox's for each of the 60 runs in the For Loop.
            MsgBox "k Value - " & k
            MsgBox "D Value - " & Worksheets("Question Bank").Cells(k + 1, 4).Value
            MsgBox "Month Value - " & Month(Date)
            MsgBox "If Result - " & Month(Date) - Worksheets("Question Bank").Cells(k + 1, 4).Value
        End If
            Rslt(i) = SrcList(k, 1)
            SrcList(k, 1) = SrcList(j, 1)
            j = j - 1
    Next i

So the value of Column D on Question Bank for all rows is currently 1. So the result of the If will always be FALSE (thus, it should go to the Else) because the end result will be 4 - (Month(Date) - 1). So you would expect, given the current value of cells in Column D, it should still be computing everything normally. But that's not the case - as I said above, I'm receiving a #VALUE! error.

 

[DushiPunda]

Uh huh,
I had forgotten that UDF's cannot "Change another cell's value." and so my #VALUE! error was resulting from the following line:

Worksheets("Question Bank").Cells(k + 1, 4).Value = Month(Date)

So after commenting this line out, everything works as expected. I tested this by changing the value in Column D for the first 60 questions/rows on Question Bank to 4 and received the expected results - the value of RandomSelection was never 1-60 (because Month(Date) - 4 = 1, which is very clearly less than 2).

Now I need to work out how to update the value of the appropriate cells in Column D on Question Bank.

 

[DushiPunda]

Got everything worked out. Here's what I finally came up with:

1.

Sub UpdateLastUsed
Application.ScreenUpdating = False

For i = 3 to 32
    Worksheets("Question Bank").Cells(Worksheets("Question Bank").Cells(i - 1, 6).Value + 1, 4).Value = DateSerial(Year(Date), Month(Date), 1)
Next i

With Worksheets("Finalize Test"
    .Unprotect
    .Cells(1, 1).Value = MonthName(Month(Date), True)
    .Protect
End With

Application.ScreenUpdating = True
End Sub

2.

Sub AutoFitRows()
Worksheets("Monthly Test").Range("A3:A32").Rows.AutoFit
Worksheets("Answer Sheet").Range("A3:A32").Rows.AutoFit
End Sub

3.

Sub UpdateHeader()
With Worksheets("Monthly Test").PageSetup
    .FirstPage.LeftHeader.Text = _
    "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "Name: __________" & Chr(10) & "Date: __________"

    .CenterHeader = 'Omitted
    .FirstPage.CenterHeader.Text = 'Omitted

    .RightHeader = _
    "" & Chr(10) & "" & Chr(10) & MonthName(Month(Date)) & " " & Year(Date) & Chr(10) & "Monthly Test"
    .FirstPage.RightHeader.Text = _
    "" & Chr(10) & "" & Chr(10) & "" & Chr(10) & MonthName(Month(Date)) & " " & Year(Date) & Chr(10) & "Monthly Test"

    .CenterFooter = 'Omitted
    .FirstPage.CenterHeader.Text = 'Omitted

    .RightFooter = "Page &P of &N"
    .FirstPage.CenterHeader.Text = "Page &P of &N"
End With

With Worksheets("Answer Sheet").PageSetup
    .CenterHeader = 'Omitted

    .RightHeader = _
    "" & Chr(10) & MonthName(Month(Date)) & " " & Year(Date) & Chr(10) & "Monthly Test" & Chr(10) & "Answer Key"

    .CenterFooter = 'Omitted
End With
End Sub

4.

Public myFileTest As String, myFileAnswer As String

Sub PDFActiveSheet()
Dim wsA As Worksheet, wbA As Workbook
Dim strName As String, strPath As String
Dim strPathFile As Variant

On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet

strPath = wbA.Path & "\"

If strPath = "" Then 'Need to fix this because based on the previous line of code, strPath will never be blank.
    strPath = Application.DefaultFilePath & "\"
End If

If wsA.Name = "Monthly Test" Then myFileTest = strPathFile
If wsA.Name = "Answer Sheet" Then myFileAnswer = strPathFile

wsA.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=strPathFile, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False, _

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

5.

Sub btnFinalize()
If Worksheets("Finalize Test").Cells(1, 1).Value = MonthName(Month(Date), True) Then
    MsgBox "You cannot do this twice in the same month."
    Exit Sub
End If

Call UpdateLastUsed
Call AutoFitRows
Call UpdateHeader

Application.ScreenUpdating = False

Worksheets("Monthly Test").Activate
    Call PDFActiveSheet

Worksheets("Answer Sheet").Activate
    Call PDFActiveSheet

Worksheets("Finalize Test").Activate

Application.ScreenUpdating = True

MsgBox "PDF files have been created: " _
& vbCrLf _
& "1. " & myFileTest _
& vbCrLf _
& "2. " & myFileAnswer
End Sub

If anyone stumbles upon this for whatever reason, feel free to reply or send me a message with any questions.