Random Draft Order 1

[gunnyhud]

My job holds a monthly draft to determine selection of items on a monthly basis. I have eight teams that select items during the draft, the only problem is that each team does not have a even amount of picks during the draft (i.e. team 1 has five picks, while team 4 has ten picks). I need some help creating a file that will allow me to enter the amount of picks each team has and then randomly assign a draft order. Thanks in advance for any help!

 

[PaulF]

Not sure if this is what you're after or not.

I've created two tables:
tbl_Teams with 3 numeric fields
TeamNum
Entries
Drawn

tbl_Draft_By_Rounds with 21 numeric fields
DraftRound
Position1 through Position20
Pirmary Key is DraftRound

This allows you to have up to 20 teams with unlimited rounds

You Populate tbl_Teams with the team number and the number of Picks (Enteries) each team has and leave the field Drawn blank

The code will determine the highest value in the field Entries to determine how many Rounds of the draft there will be. Each team will have a max of one pick per round, and if one team has two more picks than everyone else they will get the last 2 picks.

Function fDraftByRound()
Dim db As DAO.Database, rstTeams As DAO.Recordset, rstDraft As DAO.Recordset
Dim intX As Integer, intSelected As Integer, intDraws As Integer
Dim intC As Integer, intRand As Integer, intRound As Integer, intRoundPicks
Dim strF As String
Set db = CurrentDb
With DoCmd
.SetWarnings False
.RunSQL ("Delete * from tbl_Draft_By_Rounds")
.RunSQL ("UPDATE tbl_Teams SET tbl_Teams.Drawn = Null")
.SetWarnings True
End With
intDraws = DMax("Entries", "tbl_Teams")
intRand = Int(100 * Rnd())
Set rstTeams = db.OpenRecordset("tbl_Teams", dbOpenDynaset)
Set rstDraft = db.OpenRecordset("tbl_Draft_By_Rounds")
With rstDraft
For intC = 1 To intDraws
.AddNew
!DraftRound = intC
.Update
Next intC
End With
intC = 0
intRound = 1
Do While intRound < intDraws + 1
intRoundPicks = DCount("TeamNum", "tbl_Teams", "Entries >= " & intRound)
intSelected = 1
Do While intSelected < intRoundPicks + 1
intX = Right(intRand + Int(100 * Rnd()), 1)
'Debug.Print intX
With rstTeams
.FindFirst "TeamNum= " & intX
If Not .NoMatch Then
If Nz(rstTeams!Drawn, 0) < rstTeams!Entries Then
With rstDraft
.Index = "PrimaryKey"
.Seek "=", intRound
If .NoMatch Then GoTo LoopHere
For intC = 1 To 20
If rstDraft("Position" & CStr(intC)) = intX Then GoTo LoopHere
Next intC
rstDraft.Edit
rstDraft("Position" & intSelected) = intX
rstDraft.Update
End With
rstTeams.Edit
rstTeams!Drawn = Nz(rstTeams!Drawn, 0) + 1
rstTeams.Update
intSelected = intSelected + 1
End If
End If
End With
LoopHere:
Loop
intC = 0
intSelected = 0
intRound = intRound + 1
Loop
Set rstDraft = Nothing
Set rstTeams = Nothing
Set db = Nothing
MsgBox "Completed determining draft order"
End Function


PaulF

 

[gunnyhud]

That's great PaulF....how do I put all that into action? lol

 

[PaulF]

build the 2 tables, populate tbl_Teams with a record for each of the teams and number them (numerically starting with 1) and enter the number of picks into the field Entries.

Either build a form to put the code behind or put it in a module. Then call the code from either the form or the debug (immediate) window. The results will be in table tbl_Draft_By_Rounds.


PaulF

 

[gunnyhud]

Paul, I really appreciate your help...I'm having issues getting the code to work...doing something wrong.

 

[gunnyhud]

I finally got it working PualF, quick question. Is there anyway to ensure the picks are spread out fairly. For instance, is one team has 8 picks and another has 15, then all the others in the mix, how can we ensure the team with the smaller amount of picks doesn't get all the high picks versus the team with 15 getting all the low picks? Any way to spread that out?

 

[PaulF]

then it wouldn't be random would it. I thought by ensuring each team received one pick in each round until it exhausted it's pick was making it fair. I had originally used just a random process that sometimes ended up with the team with the lowest number of picks not getting a pick until the near the end of the process.

I added coding to check which position the team has piced from and if they've already picked from this position in a previous round, then to pick another team. Of course this doesn't ensure that the team with the fewest picks get high picks, it only ensures that the same team doesn't get to pick in the same position more than once until after the team with the fewest picks is finished.

Here is the new code (I decided to provide you with the new code instead of just the changes)

Function fDraftByRoundVer2()
Dim db As DAO.Database, rstTeams As DAO.Recordset, rstDraft As DAO.Recordset
Dim intX As Integer, intSelected As Integer, intDraws As Integer, intMinDraws
Dim intC As Integer, intRand As Integer, intRound As Integer, intRoundPicks
Dim strF As String
Set db = CurrentDb
With DoCmd
.SetWarnings False
.RunSQL ("Delete * from tbl_Draft_By_Rounds")
.RunSQL ("UPDATE tbl_Teams SET tbl_Teams.Drawn = Null")
.SetWarnings True
End With
intDraws = DMax("Entries", "tbl_Teams")
intMinDraws = DMin("Entries", "tbl_Teams")
intRand = Int(100 * Rnd())
Set rstTeams = db.OpenRecordset("tbl_Teams", dbOpenDynaset)
Set rstDraft = db.OpenRecordset("tbl_Draft_By_Rounds")
With rstDraft
For intC = 1 To intDraws
.AddNew
!DraftRound = intC
.Update
Next intC
End With
intC = 0
intRound = 1
Do While intRound < intDraws + 1
intRoundPicks = DCount("TeamNum", "tbl_Teams", "Entries >= " & intRound)
intSelected = 1
Do While intSelected < intRoundPicks + 1
intX = Right(intRand + Int(100 * Rnd()), 1)
'Debug.Print intX
With rstTeams
If intRound < intMinDraws + 1 Then
With rstDraft
.MoveFirst
Do While Not .EOF
If rstDraft("Position" & intSelected) = intX Then GoTo LoopHere
.MoveNext
Loop
End With
End If
.MoveFirst
.FindFirst "TeamNum= " & intX
If Not .NoMatch Then
If Nz(rstTeams!Drawn, 0) < rstTeams!Entries Then
With rstDraft
.Index = "PrimaryKey"
.Seek "=", intRound
If .NoMatch Then GoTo LoopHere
For intC = 1 To 20
If rstDraft("Position" & CStr(intC)) = intX Then GoTo LoopHere
Next intC
rstDraft.Edit
rstDraft("Position" & intSelected) = intX
rstDraft.Update
End With
rstTeams.Edit
rstTeams!Drawn = Nz(rstTeams!Drawn, 0) + 1
rstTeams.Update
intSelected = intSelected + 1
End If
End If
End With
LoopHere:
Loop
intC = 0
intSelected = 0
intRound = intRound + 1
Loop
Set rstDraft = Nothing
Set rstTeams = Nothing
Set db = Nothing
MsgBox "Completed determining draft order"
End Function

PaulF

 

[PaulF]

I discovered that this code could hang up if it had one team left in the round and that team had already selected in that spot in a previous round. The fix required an Array, a new table, a query to reset the values in that table and code to check to see if the situation existed, and to redo the round if it did. I won't paste the code (unless requested), but wanted you to know I am aware of the potential problem.

PaulF