Random Selection

 Sub RandomPick(ByRef intRecords As Integer)
 
    On Error GoTo Err_RandomPick
 
    ' Author: Mile-O-Phile
    ' History: 07-Nov-2002 - Initially written
    ' Discussion: Selects five random numbers without duplication
    '             In order to select five random records from a recordset, we must first decide which
    '             records we are going to take from the recordset.

    Dim intCounterA As Integer, intCounterB As Integer ' Loop counters
    Dim intRandom(1 To 5) As Integer ' Store for accepted numbers
    Dim intCurrent As Integer ' The current random number
    Dim intPosition As Integer ' Holds our position in the array
    Dim booUnusable As Boolean ' Determines whether number is a duplicate
    
    intPosition = 1

    For intCounterA = 1 To 5
        ' This ensures we get a random number within our given range
        intCurrent = Int(Rnd() * intRecords) + 1
        
        ' Next, we must check that the number we have just selected doesn't match any others
        For intCounterB = 1 To 5
            If (intCurrent = intRandom(intCounterB)) Then
                booUnusable = True
                Exit For
            End If
            
            If (intRandom(intCounterB) = 0) Then
                ' There will only be a zero value in the array if no value has been entered
                ' in intRandom(?) for that index so it can be safely left if a zero is seen
                Exit For
            End If
        Next intCounterB ' return the counter
        
        While booUnusable
            ' If the number generated is a duplicate then the routine should continue generating random
            ' numbers until there is a useable value
            booUnusable = False
            intCurrent = Int(Rnd() * intRecords) + 1
            For intCounterB = 1 To 5
                ' Again, the number must be checked to determine whether it is a duplicate
                If (intCurrent = intRandom(intCounterB)) Then
                    booUnusable = True
                    Exit For
                End If
            Next intCounterB ' return the counter
        Wend
        ' If a useable number is achieved then the search for that array index is considered to be complete
        intRandom(intPosition) = intCurrent
        intPosition = intPosition + 1 ' increment the array index
    Next intCounterA ' return the counter
    
    Call MakeRandomTable(intRandom())
    
Exit_RandomPick:
    Exit Sub
    
Err_RandomPick:
    MsgBox Err.Number & ": " & Err.Description, vbExclamation, "Error in Sub RandomPick"
    Resume Exit_RandomPick
    
End Sub

Sub MakeRandomTable(ByRef intRandom() As Integer)

    On Error GoTo Err_MakeRandomTable

    ' Author: Mile-O-Phile
    ' History: 07-Nov-2002 - Initially written
    ' Discussion: Writes the five randomly selected records into a temporary table
    
    Dim db As Database ' database object
    Dim rsNew As Recordset, rsQuery As Recordset ' recordset objects
    Dim intCounterA As Integer, intCounterB As Integer ' Loop counters
    
    Set db = CurrentDb
    Set rsNew = db.OpenRecordset("tblRandom")
    Set rsQuery = db.OpenRecordset("qryRandomReport")
    
    If rsNew.RecordCount = 0 Then ' If the table si empty then there is no need to delete records
        ' do nothing
    Else
        rsNew.MoveFirst
        For intCounterA = 1 To rsNew.RecordCount
            With rsNew
                .Delete
                .MoveNext
            End With
        Next intCounterA
    End If
    
    For intCounterA = 1 To DCount("[Date]", "qryRandomReport")
        For intCounterB = 1 To 5
            If intCounterA = intRandom(intCounterB) Then
                With rsNew
                    .AddNew
                    .Fields("ID") = rsQuery.Fields("ID")
                     ' ***** all all other fields were appended here
                     ' an UPDATE query may be simpler to transfer the records individually
                    .Update
                End With
            End If
        Next intCounterB
        rsQuery.MoveNext
    Next intCounterA
    
Exit_MakeRandomTable:
    Exit Sub
    
Err_MakeRandomTable:
    MsgBox Err.Number & ": " & Err.Description, vbExclamation, "Error in Sub MakeRandomTable"
    Resume Exit_MakeRandomTable
        
End Sub