Dim pairs As Object, rounds(1 To 8, 1 To 10) As String
Dim bestpairs As Object, bestrounds(1 To 10, 1 To 10) As String, bestcount As Long
Sub test_assignment()
Dim i As Long, j As Long, m As Long, k As Long, deck As String, available As Object, t As Double
Randomize Now
t = Timer
bestcount = 500
Set bestpairs = CreateObject("Scripting.Dictionary")
For m = 1 To 1000
Set pairs = CreateObject("Scripting.Dictionary")
Set available = CreateObject("Scripting.Dictionary")
For i = 1 To 10
available.Add CStr(i), 1
Next i
For i = 1 To 8
deck = IIf(Rnd < 0.5, "A", "B")
j = WorksheetFunction.RandBetween(0, available.Count - 1)
rounds(1, i) = available.Keys()(j) & ";" & deck
available.Remove available.Keys()(j)
Next i
rounds(1, 9) = available.Keys()(0)
rounds(1, 10) = available.Keys()(1)
For i = 1 To 3
For j = i + 1 To 4
pairs.Add rounds(1, i) & "," & rounds(1, j), 1
pairs.Add rounds(1, j) & "," & rounds(1, i), 1
Next j, i
For i = 5 To 7
For j = i + 1 To 8
pairs.Add rounds(1, i) & "," & rounds(1, j), 1
pairs.Add rounds(1, j) & "," & rounds(1, i), 1
Next j, i
For j = 2 To UBound(rounds)
prepare_week j
Next j
j = 0
For i = 0 To pairs.Count - 1
If Len(pairs.Items()(i)) > 2 Then j = j + 1
Next i
If j < bestcount Then
bestcount = j
For i = 1 To UBound(rounds)
For j = 1 To 10
bestrounds(i, j) = rounds(i, j)
Next j, i
Set bestpairs = pairs
End If
If bestcount = 0 Then Exit For
DoEvents
Next m
Rows("2:15").ClearContents
Columns("L:M").ClearContents
Range("A2").Resize(UBound(rounds), 10) = bestrounds
j = 1
For i = 0 To bestpairs.Count - 1
If Len(bestpairs.Items()(i)) > 2 Then
j = j + 1
If j Mod 2 = 0 Then
Cells(j / 2, "L") = bestpairs.Items()(i)
Cells(j / 2, "M") = bestpairs.Keys()(i)
End If
End If
Next i
show_byes
End Sub
Private Sub prepare_week(weeknum As Long)
Dim thisround() As String, available As Object, i As Long, j As Long
Dim playeranddeck As String, deck As String, counter As Long, notused As Boolean
ReDim thisround(1 To 8)
Set available = CreateObject("Scripting.Dictionary")
thisround(1) = rounds(weeknum - 1, 9) & ";" & IIf(Rnd < 0.5, "A", "B")
thisround(5) = rounds(weeknum - 1, 10) & ";" & IIf(Rnd < 0.5, "A", "B")
For i = 1 To 8
available.Add Split(rounds(weeknum - 1, i), ";")(0), 1
Next i
For i = 2 To 4
counter = 0
Do
notused = True
counter = counter + 1
j = WorksheetFunction.RandBetween(0, available.Count - 1)
deck = IIf(Rnd < 0.5, "A", "B")
playeranddeck = available.Keys()(j) & ";" & deck
For k = 1 To i - 1
If pairs.exists(playeranddeck & "," & thisround(k)) Then notused = False
Next k
If Not notused Then
notused = True
deck = Replace("AB", deck, "")
playeranddeck = available.Keys()(j) & ";" & deck
For k = 1 To i - 1
If pairs.exists(playeranddeck & "," & thisround(k)) Then notused = False
Next k
End If
Loop Until counter > 1000 Or notused
available.Remove available.Keys()(j)
thisround(i) = playeranddeck
Next i
For i = 6 To 8
counter = 0
Do
notused = True
counter = counter + 1
j = WorksheetFunction.RandBetween(0, available.Count - 1)
deck = IIf(Rnd < 0.5, "A", "B")
playeranddeck = available.Keys()(j) & ";" & deck
For k = 5 To i - 1
If pairs.exists(playeranddeck & "," & thisround(k)) Then notused = False
Next k
If Not notused Then
notused = True
deck = Replace("AB", deck, "")
playeranddeck = available.Keys()(j) & ";" & deck
For k = 1 To i - 1
If pairs.exists(playeranddeck & "," & thisround(k)) Then notused = False
Next k
End If
Loop Until counter > 1000 Or notused
available.Remove available.Keys()(j)
thisround(i) = playeranddeck
Next i
For i = 1 To 3
For j = i + 1 To 4
If pairs.exists(thisround(i) & "," & thisround(j)) Then
pairs(thisround(i) & "," & thisround(j)) = pairs(thisround(i) & "," & thisround(j)) & ";" & weeknum
pairs(thisround(j) & "," & thisround(i)) = pairs(thisround(j) & "," & thisround(i)) & ";" & weeknum
Else
pairs.Add thisround(i) & "," & thisround(j), weeknum
pairs.Add thisround(j) & "," & thisround(i), weeknum
End If
Next j, i
For i = 5 To 7
For j = i + 1 To 8
If pairs.exists(thisround(i) & "," & thisround(j)) Then
pairs(thisround(i) & "," & thisround(j)) = pairs(thisround(i) & "," & thisround(j)) & ";" & weeknum
pairs(thisround(j) & "," & thisround(i)) = pairs(thisround(j) & "," & thisround(i)) & ";" & weeknum
Else
pairs.Add thisround(i) & "," & thisround(j), weeknum
pairs.Add thisround(j) & "," & thisround(i), weeknum
End If
Next j, i
For i = 1 To 8
rounds(weeknum, i) = thisround(i)
Next i
rounds(weeknum, 9) = available.Keys()(0)
rounds(weeknum, 10) = available.Keys()(1)
End Sub
Private Sub show_byes()
Dim i As Long, j As Long, k As Long, inparr() As Variant, outarr(1 To 10, 1 To 2) As Variant
inparr = Range(Cells(2, "I"), Cells(Rows.Count, "J").End(xlUp)).Value
For i = 1 To UBound(inparr)
For j = 1 To 2
outarr(inparr(i, j), 2) = outarr(inparr(i, j), 2) & ";" & i
Next j
Next i
For i = 1 To UBound(outarr)
outarr(i, 1) = i
outarr(i, 2) = Mid(outarr(i, 2), 2)
Next i
Range("O1").Resize(UBound(outarr), 2) = outarr
End Sub