Option Compare Database
Option Explicit
Public Function getTopX_IDs(ByVal topX As Integer) As String
Dim strSQL As String
Dim strIDS As String
Dim rs As DAO.Recordset
Dim recCount As Integer
'Used in without repeats
strSQL = strSQL & "SELECT Top " & topX
strSQL = strSQL & " ID "
strSQL = strSQL & "FROM qryAvailableWithoutRepeat "
MsgBox strSQL
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rs.EOF And rs.BOF) Then
rs.MoveLast
rs.MoveFirst
End If
Do While Not rs.EOF
If getTopX_IDs = "" Then
getTopX_IDs = rs!id
Else
getTopX_IDs = getTopX_IDs & "," & rs!id
End If
rs.MoveNext
Loop
getTopX_IDs = getTopX_IDs
End Function
Public Sub assignCleaning(ByVal topX_IDs As String)
Dim strSQL As String
Dim aIDS() As String
Dim varID As Variant
'Used in without repeats
aIDS = Split(topX_IDs, ",")
For Each varID In aIDS
strSQL = "INSERT INTO employee_picked_table (employeeID_FK,Date_Picked) VALUES (" & varID & ", #" & Date & "#)"
CurrentDb.Execute strSQL
Next varID
End Sub
Public Sub removeFromPlay(ByVal topX_IDs As String)
'used in without repeats
Dim strSQL As String
strSQL = "UPDATE employee_table SET employee_table.inPlay = False WHERE employee_table.ID In (" & topX_IDs & ")"
CurrentDb.Execute strSQL
End Sub
Public Sub AssignWithRepeats(topX As Integer)
Dim strSQL As String
strSQL = "INSERT INTO employee_picked_table ( EmployeeID_FK, Date_Picked ) "
strSQL = strSQL & "SELECT Top " & topX
strSQL = strSQL & " ID, date() AS dtmSelected "
strSQL = strSQL & "FROM qryAvailableMyRandom"
'Debug.Print strSQL
CurrentDb.Execute strSQL
End Sub
Private Sub AssignWithRepeats2(topX As Integer)
Dim strSQL As String
Dim available As Integer
Dim topXs As Collection
Dim x As Variant
Dim rs As DAO.Recordset
Dim intID As Integer
'This is using code not the Rnd function
available = DCount("ID", "qryAvailable")
If topX > available Then
MsgBox "There is not " & topX & " available"
Else
'this returns a collection with values from
'0 to number of (avaialble - 1)
Set rs = CurrentDb.OpenRecordset("qryAvailable")
rs.MoveFirst
Set topXs = getXRandomInRange(topX, available)
For Each x In topXs
rs.AbsolutePosition = x
intID = rs!id
strSQL = "INSERT INTO employee_picked_table ( EmployeeID_FK, Date_Picked ) "
strSQL = strSQL & "VALUES ( " & intID & "," & Date & ")"
Debug.Print strSQL
CurrentDb.Execute strSQL
Next x
rs.Close
Set rs = Nothing
End If
End Sub
Public Sub AssignWithoutRepeats(topX As Integer)
Dim strIDS As String
Dim available As Integer
Dim assigned As Integer
available = DCount("ID", "qryAvailable")
MsgBox available
If available = 0 Then
CurrentDb.Execute "upQryMakeAllInPlay"
available = DCount("ID", "qryAvailableWithoutRepeats")
End If
If IsNumeric(topX) And topX > 0 Then
strIDS = getTopX_IDs(CInt(topX))
If Not strIDS = "" Then
assignCleaning (strIDS)
removeFromPlay (strIDS)
End If
'if you did not have enough people to assign then
'put all in play, then remove the just added from play and rerun
If available < topX Then
CurrentDb.Execute "upQryMakeAllInPlay"
removeFromPlay (strIDS)
strIDS = getTopX_IDs(topX - available)
assignCleaning (strIDS)
removeFromPlay (strIDS)
End If
End If
End Sub
Public Function getXRandomInRange(Xrequired As Integer, ByVal rangeTop As Integer) As Collection
Dim x As Variant
Dim colTemp As New Collection
Dim tempX As Integer
Dim inCollection As Boolean
Dim intCount As Integer
Randomize
Do Until intCount = Xrequired
inCollection = False
tempX = Fix(Rnd() * rangeTop)
For Each x In colTemp
If x = tempX Then
inCollection = True
Exit For
End If
Next x
If Not inCollection Then
colTemp.Add (tempX)
intCount = intCount + 1
End If
Loop
Set getXRandomInRange = colTemp
End Function
Public Function myRnd(id As Variant) As Double
If Not IsNull(id) Then
Randomize
myRnd = Rnd(Now() + id)
End If
End Function
Public Sub test20()
Dim I As Integer
For I = 1 To 20
AssignWithRepeats (5)
Next I
End Sub