I'm trying to use VBA to create a distribution of projects for review by judges. There are 55 projects and 11 judges. Each project will be reviewed by exactly 3 judges and each judge will review 15 projects.

The following code almost works but for some reason projects are being assigned to more than 3 judges as evidenced by elements of arrProject being greater than 3. The project number is written to column L and the value for the corresponding element in arrProject appears in column M.

Another quirk is that if the macro is executed a couple of times in succession it sometimes hangs.

I'll be greatly indebted to anyone who can provide a workaround...

Here's the code (I'm just a hack at VBA...):

Sub Macro2()
Application.ScreenUpdating = False

Const intTotalProjects As Integer = 55 'total number of projects being considered
Const intNumberJudges As Integer = 11 'total number of judges reviewing projects
Const intProjPerJudge As Integer = 15 'number of projects per judge
Const intJudgePerProj As Integer = 3 'number of judges per project

Dim booFlag As Boolean
Dim arrProject(1 To intTotalProjects) As Integer 'array to track # of judges per project
Dim arrRandom(1 To intProjPerJudge, 1 To intNumberJudges) As Integer 'array to track projects per judge


For intJudge = 1 To 11

Randomize 'Resets random seed and generates the first random value for each judge
arrRandom(1, intJudge) = Int((intTotalProjects) * Rnd + 1)
arrProject(arrRandom(1, intJudge)) = arrProject(arrRandom(1, intJudge)) + 1

For intProject = 2 To 15 'make sure judge is assigned 15 unique projects

Do

booFlag = False
arrRandom(intProject, intJudge) = Int((intTotalProjects) * Rnd + 1)

For k = 1 To intProject - 1
If arrRandom(k, intJudge) = arrRandom(intProject, intJudge) Then booFlag = True
'make sure project is not assigned more than 3 times
If arrProject(arrRandom(intProject, intJudge)) = 3 Then booFlag = True
Next k

Loop Until booFlag = False

arrProject(arrRandom(intProject, intJudge)) = arrProject(arrRandom(intProject, intJudge)) + 1

Next intProject

For l = 1 To 15 'write results to active worksheet
Range("A1").Offset(l - 1, intJudge - 1).Value = arrRandom(l, intJudge)
Next l

Next intJudge

For m = 1 To 55 'write contents of arrProject to active worksheet
Range("L1").Offset(m - 1, 0).Value = "Project " & m
Range("M1").Offset(m - 1, 0).Value = arrProject(m)
Next m

Application.ScreenUpdating = True
End Sub