Problem with code of random assignment of records

[lios1984]

Hi to everyone!!

I am having trouble with a database I am making. It's about assigning projects randomly to evaluators. Each project must be evaluated by two people. Each evaluator may be assgined only to one project. Assigning the first evaluator is successful but when it gets to assgin the second evaluator it sometimes skips parts of the code (specifically the one that it considers the 2nd evaluator bound). Why does it do that??

I tried to insert the line tblevaluators.Movefirst before entering the secon Do until..loop about making an evaluator bound.

Please help me...

Public Sub random_assignment()

Dim dbase As Object
Dim tbltemp_status As Object
Dim tblevaluators As Object
Dim tblproject As Object
Dim rando As Variant
Dim evalregion As String
Dim evalname As String
Dim evalstatus As String
Dim numfak As Integer
Dim apprassign As String

Set dbase = CurrentDb 'Opens database and tables
Set tbltemp_status = dbase.OpenRecordset("Temporary assignments")
Set tblevaluators = dbase.OpenRecordset("Evaluators")
Set tblproject = dbase.OpenRecordset("Projects")

Do Until tbltemp_status.EOF 'Deletes previous assignments
    With tbltemp_status
        .Delete
        .MoveNext
    End With
Loop

Do Until tblproject.EOF 'Updates table with projects to be assigned
    If tblproject.[Status] = "Ready to be assigned" Then
        With tbltemp_status
            .AddNew
            ![Project number] = tblproject.[Project number]
            .Update
        End With
    End If
    tblproject.MoveNext
Loop

tbltemp_status.MoveFirst 'Initialize tables
tblproject.MoveFirst

Do Until tbltemp_status.EOF 'Searches table of projects
    numfak = tbltemp_status.[Project number]
    tblevaluators.MoveFirst
    apprassign = 1
    Do Until apprassign = "0" 'Function eval is called until its value is 0
        rando = Rand(1, DCount("[ID]", "Evaluators", "[Evaluator_Status] = 'Available'"))
        evalname = DLookup("[Evaluator name]", "[Evaluators]", "[ID] =" & rando) 
        evalregion = DLookup("[Evaluator region]", "[Evaluators]", "[ID] =" & rando)
        evalstatus = DLookup("[Evaluator_Status]", "[Evaluators]", "[ID] =" & rando)
        apprassign = eval(evalregion, evalstatus, numfak) 
    Loop
    With tbltemp_status 'Insert evaluator's name
        .Edit
        .Fields("Assign to 1st evaluator") = evalname
        .Update
    End With
    
    Do Until tblevaluators.EOF 'Evaluator is temporarily taken out of the selection group
        If tblevaluators.[Evaluator name] = evalname Then
           tblevaluators.Edit
           tblevaluators![Evaluator_Status] = "Bound"
           tblevaluators.Update
        Else
           tblevaluators.MoveNext
        End If
    Loop
    
    tblproject.MoveFirst
    apprassign = "1"
    
    Do Until apprassign = "0" 'Function eval is called until its value is 0
        rando = Rand(1, DCount("[ID]", "Evaluators", "[Evaluator_Status] = 'Available'"))
        evalname = DLookup("[Evaluator name]", "[Evaluators]", "[ID] =" & rando) 
        evalregion = DLookup("[Evaluator region]", "[Evaluators]", "[ID] =" & rando)
        evalstatus = DLookup("[Evaluator_Status]", "[Evaluators]", "[ID] =" & rando)
        apprassign = eval(evalregion, evalstatus, numfak) ' Êáëåßôáé ç óõíÜñôçóç ðïõ åëÝã÷åé ôá êùëýìáôá ôïõ áîéïëïãçôÞ
    Loop
    With tbltemp_status
        .Edit
        .Fields("Assign to 2nd evaluator") = evalname
        .Update
    End With
    Do Until tblevaluators.EOF
        If tblevaluators.[Evaluator name] = evalname Then
           tblevaluators.Edit
           tblevaluators![Evaluator_Status] = "Bound"
           tblevaluators.Update
           Exit Do
        Else
            tblevaluators.MoveNext
        End If
        
    Loop
    tbltemp_status.MoveNext 'Move to next record
Loop

tblevaluators.MoveFirst 'Initialize table

Do Until tblevaluators.EOF 'Restore all evaluators in order to be random selected again on next round of assignments
    If tblevaluators.[Evaluator_Status] = "Bound" Then
       tblevaluators.Edit
       tblevaluators![Evaluator_Status] = "Available"
       tblevaluators.Update
    End If
    tblevaluators.MoveNext
Loop

DoCmd.OpenReport "Assignment", acViewPreview 'Open report with assginments
'Close tables and database
tbltemp_status.Close
tblevaluators.Close
tblproject.Close

Set tblproject = Nothing
Set tbltemp_status = Nothing
Set tblevaluators = Nothing
Set dbase = Nothing

End Sub

[ssanfu]

I've been looking at your code and have a few questions.

You have:

rando = Rand(1, DCount("[ID]", "Evaluators", "[Evaluator_Status] = 'Available'"))

Q) Why are you using the Excel worksheet function "Rand()" in the code?

apprassign = Eval(evalregion, evalstatus, numfak)

Q) What is EVAL?? A custom function? It is the same name as a built in function.
I tried the following to test the Eval code and it failed:

Sub MyTEst()
   Dim evalregion As String
   Dim evalname As String
   Dim evalstatus As String
   Dim apprassign As String
   Dim numfak As Integer

   numfak = 1000
   evalregion = "East"
   evalname = "Jack"
   evalstatus = "Bound"

   apprassign = Eval(evalregion, evalstatus, numfak)
   MsgBox apprassign
End Sub

In the "Assign to 2nd evaluator" code, it looks like there might be some corruption:

apprassign = Eval(evalregion, evalstatus, numfak) ' Êáëåßôáé ç óõíÜñôçóç ðïõ åëÝã÷åé ôá êùëýìáôá ôïõ áîéïëïãçôÞ

[lios1984]

Rand() is a function I created instead of adding it each time as line of the primary code.

Eval is a function I created in order to check some of the evaluator's characteristics. For example, it checks whether the evaluator is Available or the evaluator is in the same region as the project is.

The corruption you mention is merely some comments in a Greek font that is not recognized. Ignore it.

[ssanfu]

I would suggest changing "Eval" to a different name since it is a native Access function.... maybe "ChkEval".

Would you post the Rand() and your Eval() functions?

There are a few things that I would change in your code, but I would like to see your functions and try to execute the code before I post my change suggestions.

[lios1984]

Of course!!! I would really appreciate your help on this problem.

Public Function Rand(ByVal Low As Long, _
                     ByVal High As Long) As Long
Randomize
Rand = Int((High - Low + 1) * Rnd) + Low
End Function

Function eval(evalregion As String, evalstatus As String, numfak As Integer) As String
Dim region As Variant
Dim tblproject As Object

Set dbase = CurrentDb
Set tblproject = dbase.OpenRecordset("Projects")

region = DLookup("[Region]", "[Projects]", "[Project number] =" & numfak)
If evalstatus = "Available" Then
    If region = evalregion Then
        eval = "False"
    Else
        eval = "True"
    End If
Else
    eval = "False"
End If

tblproject.MoveFirst

tblproject.Close

Set tblproject = Nothing
Set dbase = Nothing

End Function

[ssanfu]

In reviewing your code, I have found a couple of things:
* there are a couple of undeclared variables - do you have "Option Explicit" at the top of the module?
* the variable "apprassign" was defined as a string but you had a number 1 assigned to it. (1 is not the same as a "1")
* you have "Do Until apprassign = "0", but the custom function "Eval" returns the text string "True" or "False".....

You used loops to clear a table and/or do updates.... I changed them to SQL statements.

In a COPY of your database, replace your code with mine and test it.... Please use a copy of your mdb, since I couldn't test the code.

Here are the 3 procedures:
(uses DAO - will need a reference set to Microsoft DAO 3.6 Object Library)

Option Compare Database
Option Explicit

Public Sub random_assignment()

    Dim dbase As DAO.Database
    Dim rsTemp_status As DAO.Recordset
    Dim rsEvaluators As DAO.Recordset
    Dim rsProject As DAO.Recordset
    Dim rs As DAO.Recordset
    Dim sSQL As String

    Dim rando As Variant

    Dim evalregion As String
    Dim evalname As String
    Dim evalstatus As String
    Dim apprassign As Boolean

    Dim numfak As Integer

    Set dbase = CurrentDb

    'SS ------- Deletes previous assignments
    dbase.Execute ("DELETE * FROM [Temporary assignments]"), dbFailOnError

    'Opens recordsets
    Set rsTemp_status = dbase.OpenRecordset("Temporary assignments")
    Set rsEvaluators = dbase.OpenRecordset("Evaluators")
    Set rsProject = dbase.OpenRecordset("Projects")


    'SS ------- Updates table with projects to be assigned
    sSQL = "INSERT INTO [Temporary assignments] ( [Project number] )"
    sSQL = sSQL & " SELECT Projects.[Project number]"
    sSQL = sSQL & " FROM Projects"
    sSQL = sSQL & " WHERE [Status] = 'Ready to be assigned';"
    dbase.Execute (sSQL), dbFailOnError
    rsTemp_status.Requery

    'move to beginning of recordset
    rsTemp_status.MoveFirst

    'Searches table of projects
    Do Until rsTemp_status.EOF
        numfak = rsTemp_status![Project number]
        rsEvaluators.MoveFirst

        '---------------------------------------------------------------------------------------------------------------------------------
        'select the 1st evaluator

        apprassign = True
        Do Until apprassign = False   'Function eval is called until its value is False
            rando = Rand(1, DCount("[ID]", "Evaluators", "[Evaluator_Status] = 'Available'"))

            sSQL = "SELECT [Evaluator name],[Evaluator region],[Evaluator_Status]"
            sSQL = sSQL & " FROM Evaluators"
            sSQL = sSQL & " WHERE [ID] = " & rando
            Set rs = dbase.OpenRecordset(sSQL)
            'check for record
            If Not (rs.BOF And rs.EOF) Then
                evalname = rs![Evaluator name]
                evalregion = rs![Evaluator region]
                evalstatus = rs![Evaluator_Status]

                ' returns a boolean - True or False
                apprassign = GetEval(evalregion, evalstatus, numfak)
            End If
        Loop
        rs.Close

        With rsTemp_status   'Insert evaluator's name
            .Edit
            .Fields("Assign to 1st evaluator") = evalname
            .Update
        End With

        'SS ------ Evaluator is temporarily taken out of the selection group
        sSQL = "UPDATE tblevaluators "
        sSQL = sSQL & " SET tblevaluators.[Evaluator_Status] = 'Bound'"
        sSQL = sSQL & " WHERE tblevaluators![Evaluator name] = '" & evalname & "';"
        dbase.Execute (sSQL), dbFailOnError
        '---------------------------------------------------------------------------------------------------------------------------------

        'select the 2nd evaluator

        apprassign = True
        Do Until apprassign = False   'Function eval is called until its value is False
            rando = Rand(1, DCount("[ID]", "Evaluators", "[Evaluator_Status] = 'Available'"))

            sSQL = "SELECT [Evaluator name],[Evaluator region],[Evaluator_Status]"
            sSQL = sSQL & " FROM Evaluators"
            sSQL = sSQL & " WHERE [ID] = " & rando
            Set rs = dbase.OpenRecordset(sSQL)
            If Not (rs.BOF And rs.EOF) Then
                evalname = rs![Evaluator name]
                evalregion = rs![Evaluator region]
                evalstatus = rs![Evaluator_Status]

                ' returns a boolean - True or False
                apprassign = GetEval(evalregion, evalstatus, numfak)
            End If
        Loop
        rs.Close

        With rsTemp_status
            .Edit
            .Fields("Assign to 2nd evaluator") = evalname
            .Update
        End With

        '---------------

        sSQL = "UPDATE tblevaluators "
        sSQL = sSQL & " SET tblevaluators.[Evaluator_Status] = 'Bound'"
        sSQL = sSQL & " WHERE tblevaluators![Evaluator name] = '" & evalname & "';"
        dbase.Execute (sSQL), dbFailOnError
        '---------------

        rsTemp_status.MoveNext
    Loop


    'Restore all evaluators in order to be random selected again on next round of assignments
    sSQL = "UPDATE tblevaluators "
    sSQL = sSQL & " SET tblevaluators.[Evaluator_Status] = 'Available'"
    sSQL = sSQL & " WHERE tblevaluators![Evaluator_Status] = 'Bound';"
    dbase.Execute (sSQL), dbFailOnError


    DoCmd.OpenReport "Assignment", acViewPreview   'Open report with assginments
    'Close tables and database
    rsTemp_status.Close
    rsEvaluators.Close
    rsProject.Close

    Set rsProject = Nothing
    Set rsTemp_status = Nothing
    Set rsEvaluators = Nothing
    Set rs = Nothing
    Set dbase = Nothing

End Sub



Public Function Rand(ByVal Low As Long, ByVal High As Long) As Long
   Randomize
   Rand = Int((High - Low + 1) * Rnd) + Low
End Function



Function GetEval(evalregion As String, evalstatus As String, numfak As Integer) As Boolean
   Dim region As String
   Dim dbase As DAO.Database
   Dim tblproject As DAO.Recordset

   Set dbase = CurrentDb

   'default return value to "False"
   GetEval = False

   Set tblproject = dbase.OpenRecordset("SELECT Region FROM Projects WHERE [Project number] = " & numfak)
   If Not (tblproject.BOF And tblproject.EOF) Then
      tblproject.MoveFirst
      region = tblproject!region
   End If

   If evalstatus = "Available" Then
      If region = evalregion Then
         GetEval = False
      Else
         GetEval = True
      End If
   End If

   tblproject.Close
   Set tblproject = Nothing
   Set dbase = Nothing

End Function

[lios1984]

Thank you very much for your help. I used the code in a copy of my database and it gives me "runtime error 3251: This operation is not supported by this type of object" (I traslated the error message as it's in greek for me). The debugger points to the line: rsTemp_status.Requery.

What can I do??

I feel like we're close to the solution..

[lios1984]

Now that I tried to run it again it gives me an other error: "runtime error 3061: Too few parameters. 2 were expected" and the debugger points to the line: dbase.Execute (sSQL), dbFailOnError

It seems that something is going on between those lines...

[ssanfu]

OK, which "dbase.Execute (sSQL), dbFailOnError"?? There are several.
Do you know how to set a breakpoint; set it at "Public Sub random_assignment()", then single step through the code.

[lios1984]

The one in line 38.

Sorry that I can't be more useful but I haven't really used breakpoints. I tried Step Into if you that is what you mean. If not, I'd like it if you showed me some of the tricks of the art.

[ssanfu]

Any chance that you could convert your database to A2K or A2K3?

Failing that, add this line (in blue) to the code. While on the Debug line, press F9. That sets a breakpoint. Open the Immediate Window (Ctrl-G, or menu bar "View/Immediate Window)
Execute the code. It will stop when it hits the breakpoint. Press the F8 key ("Step Into" aka "Single step") one time. Copy what is in the immediate window and post it.

    'SS ------- Updates table with projects to be assigned
    sSQL = "INSERT INTO [Temporary assignments] ( [Project number] )"
    sSQL = sSQL & " SELECT Projects.[Project number]"
    sSQL = sSQL & " FROM Projects"
    sSQL = sSQL & " WHERE [Status] = 'Ready to be assigned';"
    Debug.Print sSQL
    dbase.Execute (sSQL), dbFailOnError
    rsTemp_status.Requery

[lios1984]

I followed your instructions and this comes up in the Immediate window:

INSERT INTO [Temporary assignments] ( [Project number] ) SELECT Projects.[Project number] FROM Projects WHERE [Status] = 'Ready to be assigned';

[ssanfu]

OK. The SQL looks correct

You have a table named "Temporary assignments"?? (FYI, shouldn't use spaces in object names.)
There is a field named "Project number"?

In the "Projects" table, is there a field named "Project number"? And a field named "Status"?

Are the field types for both "Project number" field the same?

If you copy the SQL string and paste it into a new query, will it execute?

[lios1984]

I fixed that. I was too blind to see that I mispelled Status!!!!!

Now it has the same error I mentioned above:

Thank you very much for your help. I used the code in a copy of my database and it gives me "runtime error 3251: This operation is not supported by this type of object" (I traslated the error message as it's in greek for me). The debugger points to the line: rsTemp_status.Requery.

What can I do??

Sorry but I can't post the database to make it easier to fix.