小孩的學校要球隊比賽，共有八隊，28種組合，有四個時間和四處場地，安排球隊對抗規則如下：
1) 每個對抗組合最多只能比賽一次，且
2) 每一隊同一時間只能參賽一處，且
3) 同一場地各隊只能出賽一次
Dim s
Dim isDone As Boolean
Sub doit()
Set s = 組合(8)
Dim saveary(1 To 4, 1 To 4)
'rans = por1(s, saveary)
'saveary(1, 1) = "2,5"
'saveary(3, 3) = "3,6"
'saveary(4, 4) = "4,8"
isDone = False
rans = wk(saveary, 1, 1)
工作表1.Range("B2").Resize(UBound(saveary, 1), UBound(saveary, 2)) = rans
If (isDone = False) Then
MsgBox "無解"
End If
End Sub
'saveary 儲存陣列
'cx x
'cy y
Function wk(ByVal saveary, ByVal cx, ByVal cy)
If (cx > UBound(saveary, 2)) Then
cx = 1
cy = cy + 1
End If
If (cx > UBound(saveary, 2) Or _
cy > UBound(saveary, 1) Or _
isDone = True) Then
isDone = True
wk = saveary
Exit Function
End If
If (saveary(cy, cx) <> "") Then
wk = wk(saveary, cx + 1, cy)
Else
For ListIndex = 1 To s.Count
If (checkary(s(ListIndex), saveary, cx, cy) = False) Then
saveary(cy, cx) = s(ListIndex)
wk = wk(saveary, cx + 1, cy)
If isDone = True Then
Exit For
End If
End If
Next ListIndex
End If
End Function
Function checkary(ByVal arystr, ByVal saveary, ByVal x, ByVal y)
'全部檢查
For i = 1 To UBound(saveary, 1)
For j = 1 To UBound(saveary, 2)
If (saveary(i, j) = arystr) _
And (x <> j) And (i <> y) Then
checkary = True
Exit Function
End If
Next j
Next i
'橫排 檢查
qqa = Split(arystr, ",")
For j = LBound(saveary, 2) To UBound(saveary, 2)
If (j <> x) Then
For stri = 0 To 1
If InStr(1, saveary(y, j), qqa(stri)) > 0 Then
checkary = True
Exit Function
End If
Next stri
End If
Next j
'直排 檢查
For j = LBound(saveary, 1) To UBound(saveary, 1)
If (j <> y) Then
For stri = 0 To 1
If InStr(1, saveary(j, x), qqa(stri)) > 0 Then
checkary = True
Exit Function
End If
Next stri
End If
Next j
checkary = False
End Function
Function 組合(n As Integer)
Dim c As Collection
Set c = New Collection
Dim s As String
For i = 1 To n - 1
For j = i + 1 To n
c.Add (i & "," & j)
Next
Next
Set 組合 = c
End Function