Code acting strangely - please help

[fluffyozzy]

Could anyone see what is wrong with the code below? I am trying to produce 10 questions randomly chosen from a set of criteria. Number of questions to grab from each criteria is different so I did these using case (this was originally written by a very helpful forumer here). Most of the time it works okay, producing all 10 questions, but sometimes produces only 9 questions. Is there anything obviously wrong with it?

Thanks in advance...

--------------

Public Function MakeOralRandomTable()

'On Error GoTo Err_MakeOralRandomTable

Dim intCounterA As Integer, intCounterB As Integer ' Loop Counters
Dim intPosition As Integer ' The current random number position
Dim rst As Recordset ' Recordset for Random Ranges
ReDim intRandom(0) As Integer ' Store for accepted numbers

Set rst = CurrentDb.OpenRecordset("SELECT Orals.PrincipleID, Min(Orals.OralID)AS MinOfOralID,Max(Orals.OralID) AS MaxOfOralID FROM Orals GROUP BY Orals.PrincipleID;")
' MinOfOralID - Low end of ID range for random selection per PrincipleID
' MaxOfOralID - High end of ID range for random selection per PrincipleID

Randomize

Do While Not rst.EOF
Select Case rst!PrincipleID
Case 1
intCounterB = 1
Case 2
intCounterB = 1
Case 3
intCounterB = 1
Case 4
intCounterB = 2
Case 5
intCounterB = 1
Case 6
intCounterB = 1
Case 7
intCounterB = 3
End Select
For intCounterA = 1 To intCounterB
' Inflate the Random Array for new entry
ReDim Preserve intRandom(UBound(intRandom) + 1)
' Randomly select OralID in the given range for the current PrincipleID and store in Random Array
Loop_Random:
intRandom(UBound(intRandom)) = Int((rst!MaxOfOralID - rst!MinOfOralID + 1) * Rnd + rst!MinOfOralID)
If intCounterA > 1 Then
For intPosition = UBound(intRandom) - intCounterA + 1 To UBound(intRandom) - 1
If intRandom(intPosition) = intRandom(intCounterA) Then Exit For: GoTo Loop_Random
Next intPosition
End If
Next intCounterA
rst.MoveNext
Loop

rst.Close

' Clear the OralRandom table for new entries
CurrentDb.Execute "DELETE * FROM OralRandom;"

For intCounterA = 1 To 10
' Select Random position within the Random Array
intPosition = Int(UBound(intRandom) * Rnd + 1)
' Fetch OralID from the Random Array, select matching record from Orals
' and append to OralRandom
CurrentDb.Execute "INSERT INTO OralRandom SELECT Orals.* FROM Orals WHERE Orals.OralID=" & intRandom(intPosition) & ";"
' Remove selected OralID from the Random Array and deflate by 1
' to prevent duplicate selections
For intCounterB = intPosition To UBound(intRandom) - 1
intRandom(intCounterB) = intRandom(intCounterB + 1)
Next intCounterB
ReDim Preserve intRandom(UBound(intRandom) - 1)
Next intCounterA

'MakeOralRandomTable = True
'MsgBox "Oral randomisation is done successfully", vbInformation

Call PrepOralBatchID

Exit Function

'Err_MakeOralRandomTable:
'MakeOralRandomTable = False
'MsgBox "oral randomisation didn't go through", vbExclamation

End Function

 

[MarkK]

The random number generator uses Min(OralID) and Max(OralID) as the range from which pick numbers. OralIDs are probably missing from the table, and occasionally those get randomly selected. At INSERT INTO time the insert fails without warning.

What I would do is open a recordset of OralIDs for each principle, generate a random number x between zero and rst.RecordCount - 1, and then select the OralID at rst.AbsolutePosition = x.

 

[fluffyozzy]

Ooh, thank you for that suggestion. I'm not great at writing VB code, but I'll try

 

[fluffyozzy]

Ok, I suck at coding! lagbolt's suggestion sounded great up there, but I have not been able to write the code successfully - no idea where everything goes! I'm just taking stabs in the darkness at the moment

In the original code, lagbolt suggested that there may be missing OralIDs that sometimes get selected. Looking at the tables, this is not the case. There are 7 Principles and each of them has a number of corresponding OralIDs (different number of OralIDs per Principle). So, I'm not even certain why the original code sometimes produces 9 questions rather than 10 as required.

Can anyone help please? I would be eternally grateful