Office 2010 - Windows 7

In a Swiss tournament you have 10 or more teams but only 6 (possibly 7)
rounds of competition depending on the total number of teams entered.
Cleary not all teams meet each other as in a Round Robin.
We will assume we have an even number of teams (if uneven I will introduce a
ghost team as a bye round)

I am trying to write a routine that works out which team is to play which
team after each round.

The first round is random where team NO. 1 plays team NO. 2, team NO. 3
plays team NO. 4, team NO. 5 plays team NO. 6 and so on.
The teams meet and Victory Points points are allocated to each team (between
0 and 20) based on the extent of the win.

METHOD OF RE-MATCH:
In subsequent rounds a team must play a team that they haven't yet met but
as close to the RANK of the other team as possible.

In round 2 the team RANKED 1 will meet the team RANKED 2 - straight forward.

In subsequent rounds it is imperative that if the team ranked 1 has already
met the team ranked 2 the program looks down the ranking until it finds a
team it hasn't played and so on for every match.

The routine I wrote is very unwieldy, but usually works up to round 4 or
maybe 5 but then fails on 6 or 7. I am usually left with two teams that
have already met. I then go through the matches manually to reassign to get
all teams meeting a team that they have not already met. This is both
time-consuming and prone to error!

Any code that may be of assistance will be greatly appreciated!
I am sure I can tweak it to suit my needs :)

Thanks to the brains trust in advance,
Peter Bircher
Chairman of the Lower South Coast Bridge Association
+ 27 083 233 1628
Skype: peterbircher )

Yes I can see why I would get difficult after a few rounds. The problem is
lack of definition in the second part of this rule

In subsequent rounds it is imperative that if the team ranked 1 has
already met the team ranked 2 the program looks down the ranking until it
finds a team it hasn't played and so on for every match.

I think you need to define what to do if after following the above you end
up with two teams who have already played each other. Would need to start
over, maybe in the 2nd attempt first pair up rank1:rank3 (even if rank1
hasn't played rank2 and assuming rank1 hasn't played rank3), then test
rank2:rank4 and down, etc ; then if that doesn't work...? Or you could start
in reverse order, or any one of a number of other logical ways according to
your rules which you need to define!

Whatever you define it'll be a challenging little algorithm though! In
theory I guess it should be able to cater for any # of teams playing up to
#-1 rounds

Peter T

"Peter Bircher" wrote in message
...
Office 2010 - Windows 7

In a Swiss tournament you have 10 or more teams but only 6 (possibly 7)
rounds of competition depending on the total number of teams entered.
Cleary not all teams meet each other as in a Round Robin.
We will assume we have an even number of teams (if uneven I will introduce
a ghost team as a bye round)

I am trying to write a routine that works out which team is to play which
team after each round.

The first round is random where team NO. 1 plays team NO. 2, team NO. 3
plays team NO. 4, team NO. 5 plays team NO. 6 and so on.
The teams meet and Victory Points points are allocated to each team
(between 0 and 20) based on the extent of the win.

METHOD OF RE-MATCH:
In subsequent rounds a team must play a team that they haven't yet met but
as close to the RANK of the other team as possible.

In round 2 the team RANKED 1 will meet the team RANKED 2 - straight
forward.

In subsequent rounds it is imperative that if the team ranked 1 has
already met the team ranked 2 the program looks down the ranking until it
finds a team it hasn't played and so on for every match.

The routine I wrote is very unwieldy, but usually works up to round 4 or
maybe 5 but then fails on 6 or 7. I am usually left with two teams that
have already met. I then go through the matches manually to reassign to
get all teams meeting a team that they have not already met. This is both
time-consuming and prone to error!

Any code that may be of assistance will be greatly appreciated!
I am sure I can tweak it to suit my needs :)

Thanks to the brains trust in advance,
Peter Bircher
Chairman of the Lower South Coast Bridge Association
+ 27 083 233 1628
Skype: peterbircher )

On Friday, October 17, 2014 5:12:24 PM UTC+2, Peter T wrote:
Yes I can see why I would get difficult after a few rounds. The problem is

lack of definition in the second part of this rule



In subsequent rounds it is imperative that if the team ranked 1 has

already met the team ranked 2 the program looks down the ranking until it

finds a team it hasn't played and so on for every match.



I think you need to define what to do if after following the above you end

up with two teams who have already played each other. Would need to start

over, maybe in the 2nd attempt first pair up rank1:rank3 (even if rank1

hasn't played rank2 and assuming rank1 hasn't played rank3), then test

rank2:rank4 and down, etc ; then if that doesn't work...? Or you could start

in reverse order, or any one of a number of other logical ways according to

your rules which you need to define!



Whatever you define it'll be a challenging little algorithm though! In

theory I guess it should be able to cater for any # of teams playing up to

#-1 rounds



Peter T


Hi Peter T
Thank you for you response

Yes I agree it's not a simple task to develop a good algorithm.

However it is very simple to set out the rules:
1. You need to make sure that a team must play another team that they haven't yet played
2. The team that a team is matched against should ideally be as close in rank as is possible
Rule 1 is paramount and takes precedence over rule 2

Yes, it should ideally be able to cater for rounds = number of teams - 1

Regards,
Peter

"Peter Bircher" wrote in message

I've been looking at this on and off as a distraction to other things.

However it is very simple to set out the rules:
1. You need to make sure that a team must play another team that they
haven't yet played
2. The team that a team is matched against should ideally be as close in
rank as is possible
Rule 1 is paramount and takes precedence over rule 2

I know what you mean but "as close as possible" is a bit vague, but just as
well!

Yes, it should ideally be able to cater for rounds = number of teams - 1

I've got something working but buggy, at least on the assumption there is
always a solution for

rounds = number of teams - 1

and no two teams ever play each other twice.

1,2,9,8,3,5,10,4
2,1,6,4,10,7,5,8
3,4,10,7,1,6,8,9
4,3,8,2,6,10,7,1
5,6,7,9,8,1,2,10
6,5,2,10,4,3,9,7
7,8,5,3,9,2,4,6
8,7,4,1,5,9,3,2
9,10,1,5,7,8,6,3
10,9,3,6,2,4,1,5

The above (copy & Text-to-columns) represents 10 teams, 7 rounds already
played.
Columns 2 to 7 represent rounds where the team in col-1 has played the team
in col-2 to col-7 (assume pairings were made according to the rules).

Two more rounds should be possible (8 & 9) irrespective of rankings, but I
can't make a valid list for round-8. I must be missing something obvious
which I can't see for looking! Can you suggest a list for round-8?

Regards,
Peter T

On Tuesday, October 21, 2014 8:14:44 PM UTC+2, Peter T wrote:
"Peter Bircher" wrote in message



I've been looking at this on and off as a distraction to other things.



However it is very simple to set out the rules:

1. You need to make sure that a team must play another team that they

haven't yet played

2. The team that a team is matched against should ideally be as close in

rank as is possible

Rule 1 is paramount and takes precedence over rule 2



I know what you mean but "as close as possible" is a bit vague, but just as

well!



Yes, it should ideally be able to cater for rounds = number of teams - 1



I've got something working but buggy, at least on the assumption there is

always a solution for



rounds = number of teams - 1



and no two teams ever play each other twice.



1,2,9,8,3,5,10,4

2,1,6,4,10,7,5,8

3,4,10,7,1,6,8,9

4,3,8,2,6,10,7,1

5,6,7,9,8,1,2,10

6,5,2,10,4,3,9,7

7,8,5,3,9,2,4,6

8,7,4,1,5,9,3,2

9,10,1,5,7,8,6,3

10,9,3,6,2,4,1,5



The above (copy & Text-to-columns) represents 10 teams, 7 rounds already

played.

Columns 2 to 7 represent rounds where the team in col-1 has played the team

in col-2 to col-7 (assume pairings were made according to the rules).



Two more rounds should be possible (8 & 9) irrespective of rankings, but I

can't make a valid list for round-8. I must be missing something obvious

which I can't see for looking! Can you suggest a list for round-8?



Regards,

Peter T

Hi Peter

That is absolutely fantastic!
If you have achieved this via VBA I am sure that will be more than adequate for my needs.

Why?

I need to clarify something that will make the goal slightly less onerous!
I said "Yes, it should ideally be able to cater for rounds = number of teams - 1"
However, for a Swiss, in reality, you only need 6 rounds to have a decent competition for 10 teams right up to 20 teams! Only from 22 teams is a 7th round suggested. This may seem astounding to the inexperienced.

I will explain.

There is a formula* that works out the minimum number of rounds needed in a Swiss tournament. Any more and the ranking starts unravelling because it gets harder and harder to find teams of comparable rank to play against and the ranking actually goes awry late in the competition with less than optimum results!

*Rounds = log2N + 2 where N is the number of teams i.e. =ROUND(LOG(B3,2)+2,0) where B3 is the number of teams

So I am more than ready to try your code and do some testing!

Thanks, once again for your time and commitment to this problem.

Greatly appreciated,
Peter Bircher

"Peter Bircher" wrote in message

[snip]

If you have achieved this via VBA I am sure that will be more
than adequate for my needs.

A UDF. With a bit of cleaning up (be patient) it might be OK for your needs
but it's a long way from meeting the objective I set out with!

There is a formula* that works out the minimum number of
rounds needed in a Swiss tournament. Any more and the
ranking starts unravelling because it gets harder and harder
to find teams of comparable rank to play against and the ranking
actually goes awry late in the competition with less than optimum results!

I wondered about that. In my testing I noticed with increasing rounds the
sum of the "best" differences in paired rankings tended to increase, from an
"optimal minimum = # of teams", to an extent it makes little difference to
ignore the rankings and simply make a list that complies with the rule no
two teams to play each other twice.

And that's where I got to with my last post. Testing with 10 teams & 9
rounds, if can't make a list taking ranks into account ignore the ranks.
More often than not I end up with 9 good lists, but sometimes it fails
trying to make the (so far only the) 8th list even ignoring ranks.

Did you manage to make an 8th list with that sample I posted, or can you see
anything wrong with the 7 lists?

If neither maybe there are some scenarios where "rounds = number of teams -
1" is not possible, but still think I'm missing something stupid!

Regards,
Peter

"Peter Bircher" wrote in message

I am trying to write a routine that works out which team is to play which
team after each round.

The first round is random where team NO. 1 plays team NO. 2, team NO. 3
plays team NO. 4, team NO. 5 plays team NO. 6 and so on.
The teams meet and Victory Points points are allocated to each team
(between 0 and 20) based on the extent of the win.

METHOD OF RE-MATCH:
In subsequent rounds a team must play a team that they haven't yet met but
as close to the RANK of the other team as possible.

In round 2 the team RANKED 1 will meet the team RANKED 2 - straight
forward.

In subsequent rounds it is imperative that if the team ranked 1 has
already met the team ranked 2 the program looks down the ranking until it
finds a team it hasn't played and so on for every match.

This is a long way from optimised but seems OK for up to about 40 teams,
with more could get very slow.
It sometimes fails making round (#Teams - 2), not sure if a bug or sometimes
not possible. There should be code 269 lines from 'Option Explicit' to 'End
Code', do Debug / Compile in case of word-wrap. More in adjacent post how to
use it.

Option Explicit ' Peter-T
Public Const gcbDebug As Boolean = True ' testing & debugging

Function RobinPairs(ref_ranks, Optional ref_Prev, Optional bAscending)
' ref_ranks: scores or ranks, dup's no problem
' ref_Prev: id's (integers) of previously played teams, optional
' bAscending: best=low (eg ranks) True, best=high (eg scores) False
Dim bIgnoreRanks As Boolean
Dim i As Long, j As Long, k As Long
Dim cnt As Long, t2 As Long
Dim aRanks, aPrev
Dim aOrder() As Long
Dim arrOut() As Long
Dim v

bIgnoreRanks = True ' if can't make list of close ranks

If Application.Caller.Parent.Name < ActiveSheet.Name Then
' only recalc if activesheet ?
' Exit Function 'comment if/as required
End If

On Error GoTo errH

If VarType(ref_ranks(1)) = vbEmpty Then
RobinPairs = ""
Exit Function
End If

cnt = ref_ranks.Rows.Count
aRanks = ref_ranks.Value

If Not IsMissing(ref_Prev) Then
aPrev = ref_Prev.Value
For Each v In aPrev
If v = 0 Then
RobinPairs = -1
Exit Function
End If
Next
End If

IndexBubble aRanks, 1, aOrder, CBool(bAscending)

While (t2 = 0) And (k < cnt)
If gcbDebug Then
ReDim arrOut(1 To cnt + 1, 1 To 1) As Long
Else
ReDim arrOut(1 To cnt, 1 To 1) As Long
End If
k = k + 1

For i = 1 To cnt - 1
If arrOut(aOrder(i), 1) = 0 Then
If k = cnt Then
If bIgnoreRanks Then
Exit For
Else
j = 1 ' failed but reset default
End If
ElseIf i = k Then
j = k
Else
j = 1
End If

t2 = RankPairs(aPrev, arrOut, aOrder, i + j, cnt,
(aOrder(i)))

If t2 Then
arrOut(aOrder(i), 1) = aOrder(t2)
arrOut(aOrder(t2), 1) = aOrder(i)
ElseIf k < cnt Then
Exit For
End If
End If
Next
Wend

If bIgnoreRanks And k = cnt Then
If PairIgnoreRanks(aPrev, arrOut, cnt) = False Then
' Failed, maybe make a best list with 2 teams replaying ?
End If
k = -k ' flag PairIgnoreRanks used
End If

If gcbDebug Then '
arrOut(cnt + 1, 1) = k ' While/Wend count or PairIgnoreRanks
End If
RobinPairs = arrOut

Exit Function
errH:
If gcbDebug Then
Stop
Resume
Else
Debug.Print Application.Caller.Address & vbCr & Err.Description
End If
End Function

Function IndexBubble(arrIn, col As Long, arrIndex() As Long, _
bAscending As Boolean)
' arrIn: 2D array (remains unchanged)
' col: the colum in arrIn to sort
' arrIndex: sorted indexes
Dim i As Long, j As Long, tmp As Long

ReDim arrIndex(LBound(arrIn) To UBound(arrIn)) As Long
For i = LBound(arrIndex) To UBound(arrIndex)
arrIndex(i) = i
Next
For i = LBound(arrIndex) + 1 To UBound(arrIndex)
For j = LBound(arrIndex) To UBound(arrIndex) - 1
If bAscending Then
If arrIn(arrIndex(i), col) < arrIn(arrIndex(j), col) Then
tmp = arrIndex(i)
arrIndex(i) = arrIndex(j):
arrIndex(j) = tmp
End If
Else
If arrIn(arrIndex(i), col) arrIn(arrIndex(j), col) Then
tmp = arrIndex(i)
arrIndex(i) = arrIndex(j)
arrIndex(j) = tmp
End If
End If
Next
Next
End Function
Function RankPairs(aPrev, aPaired() As Long, aOrder() As Long, _
iNext As Long, cnt As Long, team As Long) As Long
Dim i As Long, j As Long, k As Long, flip As Long
Dim iFwd As Long, iBack As Long
Dim bPlayed As Boolean

On Error GoTo errH
iBack = iNext - 1
iFwd = iNext - 1

For k = 1 To cnt
iFwd = iFwd + 1
iBack = iBack - 1
i = iFwd
For flip = 1 To 2
If (i = 1) And (i <= cnt) Then
If aPaired(aOrder(i), 1) = 0 Then
If Not IsEmpty(aPrev) Then
For j = 1 To UBound(aPrev, 2)
If aPrev(team, j) = aOrder(i) Then
bPlayed = True
Exit For
End If
Next
End If
If bPlayed Then
bPlayed = False
ElseIf team = aOrder(i) Then
' can't play self
Else
RankPairs = i
Exit Function
End If
End If
End If
i = iBack
Next
Next
Exit Function
errH:
If gcbDebug Then
Stop
Resume
Else
Debug.Print "RankPairs: " & Err.Description
End If
End Function

Function PairIgnoreRanks(aPrev, arrOut, cnt As Long) As Boolean
Dim i As Long, j As Long, k As Long
Dim arrB() As Boolean
Dim arrUnPlyd() As Long
Dim arrTeam2

On Error GoTo errExit
cnt = UBound(aPrev)
ReDim arrUnPlyd(1 To cnt, 1 To cnt - UBound(aPrev, 2) - 1)
ReDim arrTeam2(1 To cnt)

For i = 1 To cnt
ReDim arrB(1 To cnt)
k = 0
For j = 1 To UBound(aPrev, 2)
arrB(aPrev(i, j)) = True
Next
arrB(i) = True
For j = 1 To cnt
If Not arrB(j) Then
k = k + 1
arrUnPlyd(i, k) = j
End If
Next
Next
If recFindUnplayed(arrUnPlyd, arrTeam2, 0, cnt) Then
For i = 1 To cnt
arrOut(i, 1) = arrTeam2(i)
Next
PairIgnoreRanks = True
End If

Exit Function
errExit:
If gcbDebug Then
Stop
Resume
Else
Debug.Print "PairIgnoreRanks: " & Err.Description
End If
End Function

Function recFindUnplayed(arrUnPlyd() As Long, arrTeam2, ByVal Level, cnt,
Optional ByVal Stack As Long) As Boolean
Dim b As Boolean
Dim i As Long, j As Long
Dim aTmp
Static maxStack As Long, recCnt As Long
Stack = Stack + 1
If Stack maxStack Then maxStack = Stack
recCnt = recCnt + 1

aTmp = arrTeam2
Level = Level + 1
For i = Level To cnt
If aTmp(i) = 0 Then ' not yet paired
For j = 1 To UBound(arrUnPlyd, 2)
b = False
If aTmp(arrUnPlyd(i, j)) = 0 Then
aTmp(arrUnPlyd(i, j)) = i
aTmp(i) = arrUnPlyd(i, j)
b = recFindUnplayed(arrUnPlyd, aTmp, ByVal Level, cnt,
Stack)
If Not b Then
aTmp = arrTeam2
Else
arrTeam2 = aTmp
recFindUnplayed = True
'If Stack = 1 Then Call recStats(recCnt, maxStack)
Exit Function
End If
End If
Next
If Not b Then
recFindUnplayed = False
'If Stack = 1 Then Call recStats(recCnt, maxStack)
Exit Function
End If
End If
Next
arrTeam2 = aTmp
'If Stack = 1 Then Call recStats(recCnt, maxStack)
recFindUnplayed = True

End Function

Sub recStats(recCnt As Long, maxStack As Long)
If gcbDebug Then
Debug.Print "recCnt: "; recCnt, "maxStack: "; maxStack
End If
maxStack = 0: recCnt = 0
End Sub

'''''''''''End code mod-1''''''

"Peter T" wrote in message
This is a long way from optimised but seems OK for up to about 40 teams,
with more could get very slow.
It sometimes fails making round (#Teams - 2), not sure if a bug or
sometimes not possible. There should be code 269 lines from 'Option
Explicit' to 'End Code', do Debug / Compile in case of word-wrap.

Looks like 3 lines got wrapped. Below some code to test and demo the main
UDF RobinPairs, paste into a second module and run Tester.

Sampledata() makes random ranks for (#teams-1) for rounds, formulas applied
with Tester()
To prepare a list for say round 5, the UDF reads the ranks resulting from
round-4 and the history of the previous match pairs in the 3 preceding
rounds. Quite a bit more to explain, but hopfully clearer after trying it.

Regards,
Peter T

119 lines 'Option Explicit to 'End code'

Option Explicit
Private Const mcTeams As Long = 10

Sub Tester()
Dim x As Long, T As Long
Dim sF As String

ActiveSheet.UsedRange.Clear
SampleData

T = mcTeams
If gcbDebug Then x = 1

sF = "=RobinPairs(B2:B" & T + 1 & ",,TRUE)"
Range("B" & 3 + T).Resize(T).FormulaArray = sF

sF = "=RobinPairs(C$2:C$" & T + 1 & ",$B$" & 3 + T & _
":B$" & 2 + T * 2 & ",TRUE)"
With Range("C" & 3 + T)
.Resize(T + x).FormulaArray = sF
.Resize(T + x).AutoFill .Resize(T + x, T - 2)
End With

sF = "=IF(COUNTIF(B" & T + 3 & ":B" & 2 + T * 2
sF = sF & ",""<=0""),IF(COUNTIF(B" & 3 + T & ":B" & 2 + T * 2 & ",-1),"
sF = sF & """Abort"",""Fail""),""ok"")"
Range("B" & 4 + T * 2).Resize(, T - 1).Formula = sF

If gcbDebug Then
' ApplyFormula_RankDiff ' may need to recalc this
End If
End Sub

Sub SampleData()
Dim r As Long, c As Long, T As Long
' put a button on the sheet to call this macro
T = mcTeams
[b1] = "Ranks or scores": [b1].Offset(T + 1) = "Opponent Team-ID"
Range("B2").Resize(T) = 0

ReDim arr(1 To T, 1 To 1) 'As Long
For r = 1 To T: arr(r, 1) = "Team-" & r: Next
Range("A2").Resize(T) = arr
Range("A" & 3 + T).Resize(T) = arr

ReDim arrRnd(1 To T, 1 To 1) As Double
ReDim arrIdx(1 To T) As Long
ReDim arrRanks(1 To T, 1 To T - 1) As Long

For c = 1 To T - 1
For r = 1 To T: arrRnd(r, 1) = Rnd(): Next
IndexBubble arrRnd, 1, arrIdx, True
For r = 1 To T: arrRanks(r, c) = arrIdx(r): Next
Next
Range("C2").Resize(T, T - 1).Value = arrRanks
End Sub

Sub ApplyFormula_RankDiff()
Dim T As Long
Dim sF As String
T = mcTeams

sF = "=rankdiff(B2:B" & 1 + T & ", B" & 3 + T & ":B" & 2 + T * 2 & ")"
With Range("B" & 6 + T * 2).Resize(T + 1)
.FormulaArray = sF
.AutoFill .Resize(T + 1, T - 1)
.Resize(T + 1, T - 1).Calculate
.Offset(T, -1).Resize(1) = "Sum(Rank-diffs) - count"
End With
' may need to force a recalc
End Sub

Function RankDiff(ref_ranks As Range, ref_Play As Range, Optional
bAscending)
Dim i As Long, j As Long, T As Long
Dim rk1 As Long, rk2 As Long
Dim cnt As Long
Dim aRanks, aPlay
Dim aOrder() As Long, arrOut() As Long
Dim tot As Long
On Error GoTo errExit
aRanks = ref_scores.Value
aPlay = ref_Play.Value
cnt = ref_scores.Rows.Count

ReDim arrOut(1 To cnt + 1, 1 To 1)
ReDim aOrder(1 To cnt)

IndexBubble aRanks, 1, aOrder, CBool(bAscending)

rk1 = 0
For i = 1 To cnt
For j = 1 To cnt
If i = aOrder(j) Then
rk1 = j
Exit For
End If
Next
If rk1 Then
T = CLng(ref_Play(i, 1).Text) ' kludge
For j = 1 To cnt
If T = aOrder(j) Then
rk2 = j
Exit For
End If
Next
End If
If rk2 Then
arrOut(i, 1) = rk1 - rk2
rk1 = 0: rk2 = 0
tot = tot + Abs(arrOut(i, 1))
End If
Next
arrOut(cnt + 1, 1) = tot - cnt
RankDiff = arrOut
Exit Function
errExit:
RankDiff = CVErr(xlValue)
End Function
''''''End code Mod-2''''

Hi Peter

Wow!
Thanks so much for your time and persistence. I can't wait to give it a try.

I haven't had a chance to go through all the code yet. Just glanced at some
lines.
I need to get to bed as its after midnight here in South Africa.

I am playing in a tournament (standard pairs) in Durban over the week-end,
so won't have a chance to do anything from Friday to Monday.

But I might get a chance to start looking at it some time tomorrow. I am
sure I will need some help - so I hope I will be able to pick your brain
from time to time until I have it working.

By the way
1. A typical Swiss will usually only have between 10 and 20 teams so speed
(or lack of it) shouldn't be a problem
2. When you have rounds available = number of teams - 1, then you play a
Round Robin where every team will meet every other team using a pre-set
movement (a standard full Howell, mirrored for the other pair)

Regards,
Peter B

"Peter T" wrote in message ...


"Peter T" wrote in message
This is a long way from optimised but seems OK for up to about 40 teams,
with more could get very slow.
It sometimes fails making round (#Teams - 2), not sure if a bug or
sometimes not possible. There should be code 269 lines from 'Option
Explicit' to 'End Code', do Debug / Compile in case of word-wrap.

Looks like 3 lines got wrapped. Below some code to test and demo the main
UDF RobinPairs, paste into a second module and run Tester.

Sampledata() makes random ranks for (#teams-1) for rounds, formulas applied
with Tester()
To prepare a list for say round 5, the UDF reads the ranks resulting from
round-4 and the history of the previous match pairs in the 3 preceding
rounds. Quite a bit more to explain, but hopfully clearer after trying it.

Regards,
Peter T

119 lines 'Option Explicit to 'End code'

Option Explicit
Private Const mcTeams As Long = 10

Sub Tester()
Dim x As Long, T As Long
Dim sF As String

ActiveSheet.UsedRange.Clear
SampleData

T = mcTeams
If gcbDebug Then x = 1

sF = "=RobinPairs(B2:B" & T + 1 & ",,TRUE)"
Range("B" & 3 + T).Resize(T).FormulaArray = sF

sF = "=RobinPairs(C$2:C$" & T + 1 & ",$B$" & 3 + T & _
":B$" & 2 + T * 2 & ",TRUE)"
With Range("C" & 3 + T)
.Resize(T + x).FormulaArray = sF
.Resize(T + x).AutoFill .Resize(T + x, T - 2)
End With

sF = "=IF(COUNTIF(B" & T + 3 & ":B" & 2 + T * 2
sF = sF & ",""<=0""),IF(COUNTIF(B" & 3 + T & ":B" & 2 + T * 2 & ",-1),"
sF = sF & """Abort"",""Fail""),""ok"")"
Range("B" & 4 + T * 2).Resize(, T - 1).Formula = sF

If gcbDebug Then
' ApplyFormula_RankDiff ' may need to recalc this
End If
End Sub

Sub SampleData()
Dim r As Long, c As Long, T As Long
' put a button on the sheet to call this macro
T = mcTeams
[b1] = "Ranks or scores": [b1].Offset(T + 1) = "Opponent Team-ID"
Range("B2").Resize(T) = 0

ReDim arr(1 To T, 1 To 1) 'As Long
For r = 1 To T: arr(r, 1) = "Team-" & r: Next
Range("A2").Resize(T) = arr
Range("A" & 3 + T).Resize(T) = arr

ReDim arrRnd(1 To T, 1 To 1) As Double
ReDim arrIdx(1 To T) As Long
ReDim arrRanks(1 To T, 1 To T - 1) As Long

For c = 1 To T - 1
For r = 1 To T: arrRnd(r, 1) = Rnd(): Next
IndexBubble arrRnd, 1, arrIdx, True
For r = 1 To T: arrRanks(r, c) = arrIdx(r): Next
Next
Range("C2").Resize(T, T - 1).Value = arrRanks
End Sub

Sub ApplyFormula_RankDiff()
Dim T As Long
Dim sF As String
T = mcTeams

sF = "=rankdiff(B2:B" & 1 + T & ", B" & 3 + T & ":B" & 2 + T * 2 & ")"
With Range("B" & 6 + T * 2).Resize(T + 1)
.FormulaArray = sF
.AutoFill .Resize(T + 1, T - 1)
.Resize(T + 1, T - 1).Calculate
.Offset(T, -1).Resize(1) = "Sum(Rank-diffs) - count"
End With
' may need to force a recalc
End Sub

Function RankDiff(ref_ranks As Range, ref_Play As Range, Optional
bAscending)
Dim i As Long, j As Long, T As Long
Dim rk1 As Long, rk2 As Long
Dim cnt As Long
Dim aRanks, aPlay
Dim aOrder() As Long, arrOut() As Long
Dim tot As Long
On Error GoTo errExit
aRanks = ref_scores.Value
aPlay = ref_Play.Value
cnt = ref_scores.Rows.Count

ReDim arrOut(1 To cnt + 1, 1 To 1)
ReDim aOrder(1 To cnt)

IndexBubble aRanks, 1, aOrder, CBool(bAscending)

rk1 = 0
For i = 1 To cnt
For j = 1 To cnt
If i = aOrder(j) Then
rk1 = j
Exit For
End If
Next
If rk1 Then
T = CLng(ref_Play(i, 1).Text) ' kludge
For j = 1 To cnt
If T = aOrder(j) Then
rk2 = j
Exit For
End If
Next
End If
If rk2 Then
arrOut(i, 1) = rk1 - rk2
rk1 = 0: rk2 = 0
tot = tot + Abs(arrOut(i, 1))
End If
Next
arrOut(cnt + 1, 1) = tot - cnt
RankDiff = arrOut
Exit Function
errExit:
RankDiff = CVErr(xlValue)
End Function
''''''End code Mod-2''''

Hi Peter

I have been testing the code after eventually getting it to apply to my
program, the initial test worked absolutely beautifully. :)
I want to run several tests more over 6 or 7 rounds with 10 (or more) teams
simulating differing tournament scenarios.

After an initial struggle to see how to use the array formulae on the sheet
it all came right.

Thanks ever so much. It certainly will make the running of a Swiss Teams a
pleasure in the future.
However, I am sure that I will be tweaking it some more before releasing.

If you would like to have a copy of the finished product for use at your
bridge club, feel free to ask.

Warmest regards,
Peter Bircher

"Peter T" wrote in message ...

"Peter Bircher" wrote in message

I am trying to write a routine that works out which team is to play which
team after each round.

The first round is random where team NO. 1 plays team NO. 2, team NO. 3
plays team NO. 4, team NO. 5 plays team NO. 6 and so on.
The teams meet and Victory Points points are allocated to each team
(between 0 and 20) based on the extent of the win.

METHOD OF RE-MATCH:
In subsequent rounds a team must play a team that they haven't yet met but
as close to the RANK of the other team as possible.

In round 2 the team RANKED 1 will meet the team RANKED 2 - straight
forward.

In subsequent rounds it is imperative that if the team ranked 1 has
already met the team ranked 2 the program looks down the ranking until it
finds a team it hasn't played and so on for every match.

This is a long way from optimised but seems OK for up to about 40 teams,
with more could get very slow.
It sometimes fails making round (#Teams - 2), not sure if a bug or sometimes
not possible. There should be code 269 lines from 'Option Explicit' to 'End
Code', do Debug / Compile in case of word-wrap. More in adjacent post how to
use it.

Option Explicit ' Peter-T
Public Const gcbDebug As Boolean = True ' testing & debugging

Function RobinPairs(ref_ranks, Optional ref_Prev, Optional bAscending)
' ref_ranks: scores or ranks, dup's no problem
' ref_Prev: id's (integers) of previously played teams, optional
' bAscending: best=low (eg ranks) True, best=high (eg scores) False
Dim bIgnoreRanks As Boolean
Dim i As Long, j As Long, k As Long
Dim cnt As Long, t2 As Long
Dim aRanks, aPrev
Dim aOrder() As Long
Dim arrOut() As Long
Dim v

bIgnoreRanks = True ' if can't make list of close ranks

If Application.Caller.Parent.Name < ActiveSheet.Name Then
' only recalc if activesheet ?
' Exit Function 'comment if/as required
End If

On Error GoTo errH

If VarType(ref_ranks(1)) = vbEmpty Then
RobinPairs = ""
Exit Function
End If

cnt = ref_ranks.Rows.Count
aRanks = ref_ranks.Value

If Not IsMissing(ref_Prev) Then
aPrev = ref_Prev.Value
For Each v In aPrev
If v = 0 Then
RobinPairs = -1
Exit Function
End If
Next
End If

IndexBubble aRanks, 1, aOrder, CBool(bAscending)

While (t2 = 0) And (k < cnt)
If gcbDebug Then
ReDim arrOut(1 To cnt + 1, 1 To 1) As Long
Else
ReDim arrOut(1 To cnt, 1 To 1) As Long
End If
k = k + 1

For i = 1 To cnt - 1
If arrOut(aOrder(i), 1) = 0 Then
If k = cnt Then
If bIgnoreRanks Then
Exit For
Else
j = 1 ' failed but reset default
End If
ElseIf i = k Then
j = k
Else
j = 1
End If

t2 = RankPairs(aPrev, arrOut, aOrder, i + j, cnt,
(aOrder(i)))

If t2 Then
arrOut(aOrder(i), 1) = aOrder(t2)
arrOut(aOrder(t2), 1) = aOrder(i)
ElseIf k < cnt Then
Exit For
End If
End If
Next
Wend

If bIgnoreRanks And k = cnt Then
If PairIgnoreRanks(aPrev, arrOut, cnt) = False Then
' Failed, maybe make a best list with 2 teams replaying ?
End If
k = -k ' flag PairIgnoreRanks used
End If

If gcbDebug Then '
arrOut(cnt + 1, 1) = k ' While/Wend count or PairIgnoreRanks
End If
RobinPairs = arrOut

Exit Function
errH:
If gcbDebug Then
Stop
Resume
Else
Debug.Print Application.Caller.Address & vbCr & Err.Description
End If
End Function

Function IndexBubble(arrIn, col As Long, arrIndex() As Long, _
bAscending As Boolean)
' arrIn: 2D array (remains unchanged)
' col: the colum in arrIn to sort
' arrIndex: sorted indexes
Dim i As Long, j As Long, tmp As Long

ReDim arrIndex(LBound(arrIn) To UBound(arrIn)) As Long
For i = LBound(arrIndex) To UBound(arrIndex)
arrIndex(i) = i
Next
For i = LBound(arrIndex) + 1 To UBound(arrIndex)
For j = LBound(arrIndex) To UBound(arrIndex) - 1
If bAscending Then
If arrIn(arrIndex(i), col) < arrIn(arrIndex(j), col) Then
tmp = arrIndex(i)
arrIndex(i) = arrIndex(j):
arrIndex(j) = tmp
End If
Else
If arrIn(arrIndex(i), col) arrIn(arrIndex(j), col) Then
tmp = arrIndex(i)
arrIndex(i) = arrIndex(j)
arrIndex(j) = tmp
End If
End If
Next
Next
End Function
Function RankPairs(aPrev, aPaired() As Long, aOrder() As Long, _
iNext As Long, cnt As Long, team As Long) As Long
Dim i As Long, j As Long, k As Long, flip As Long
Dim iFwd As Long, iBack As Long
Dim bPlayed As Boolean

On Error GoTo errH
iBack = iNext - 1
iFwd = iNext - 1

For k = 1 To cnt
iFwd = iFwd + 1
iBack = iBack - 1
i = iFwd
For flip = 1 To 2
If (i = 1) And (i <= cnt) Then
If aPaired(aOrder(i), 1) = 0 Then
If Not IsEmpty(aPrev) Then
For j = 1 To UBound(aPrev, 2)
If aPrev(team, j) = aOrder(i) Then
bPlayed = True
Exit For
End If
Next
End If
If bPlayed Then
bPlayed = False
ElseIf team = aOrder(i) Then
' can't play self
Else
RankPairs = i
Exit Function
End If
End If
End If
i = iBack
Next
Next
Exit Function
errH:
If gcbDebug Then
Stop
Resume
Else
Debug.Print "RankPairs: " & Err.Description
End If
End Function

Function PairIgnoreRanks(aPrev, arrOut, cnt As Long) As Boolean
Dim i As Long, j As Long, k As Long
Dim arrB() As Boolean
Dim arrUnPlyd() As Long
Dim arrTeam2

On Error GoTo errExit
cnt = UBound(aPrev)
ReDim arrUnPlyd(1 To cnt, 1 To cnt - UBound(aPrev, 2) - 1)
ReDim arrTeam2(1 To cnt)

For i = 1 To cnt
ReDim arrB(1 To cnt)
k = 0
For j = 1 To UBound(aPrev, 2)
arrB(aPrev(i, j)) = True
Next
arrB(i) = True
For j = 1 To cnt
If Not arrB(j) Then
k = k + 1
arrUnPlyd(i, k) = j
End If
Next
Next
If recFindUnplayed(arrUnPlyd, arrTeam2, 0, cnt) Then
For i = 1 To cnt
arrOut(i, 1) = arrTeam2(i)
Next
PairIgnoreRanks = True
End If

Exit Function
errExit:
If gcbDebug Then
Stop
Resume
Else
Debug.Print "PairIgnoreRanks: " & Err.Description
End If
End Function

Function recFindUnplayed(arrUnPlyd() As Long, arrTeam2, ByVal Level, cnt,
Optional ByVal Stack As Long) As Boolean
Dim b As Boolean
Dim i As Long, j As Long
Dim aTmp
Static maxStack As Long, recCnt As Long
Stack = Stack + 1
If Stack maxStack Then maxStack = Stack
recCnt = recCnt + 1

aTmp = arrTeam2
Level = Level + 1
For i = Level To cnt
If aTmp(i) = 0 Then ' not yet paired
For j = 1 To UBound(arrUnPlyd, 2)
b = False
If aTmp(arrUnPlyd(i, j)) = 0 Then
aTmp(arrUnPlyd(i, j)) = i
aTmp(i) = arrUnPlyd(i, j)
b = recFindUnplayed(arrUnPlyd, aTmp, ByVal Level, cnt,
Stack)
If Not b Then
aTmp = arrTeam2
Else
arrTeam2 = aTmp
recFindUnplayed = True
'If Stack = 1 Then Call recStats(recCnt, maxStack)
Exit Function
End If
End If
Next
If Not b Then
recFindUnplayed = False
'If Stack = 1 Then Call recStats(recCnt, maxStack)
Exit Function
End If
End If
Next
arrTeam2 = aTmp
'If Stack = 1 Then Call recStats(recCnt, maxStack)
recFindUnplayed = True

End Function

Sub recStats(recCnt As Long, maxStack As Long)
If gcbDebug Then
Debug.Print "recCnt: "; recCnt, "maxStack: "; maxStack
End If
maxStack = 0: recCnt = 0
End Sub

'''''''''''End code mod-1''''''

"Peter Bircher" wrote in message

Hi Peter
Hi Peter!

I have been testing the code after eventually getting it to apply to my
program, the initial test worked absolutely beautifully. :)

Great!

I want to run several tests more over 6 or 7 rounds with 10 (or more)
teams simulating differing tournament scenarios.

If only up to (#Teams - 3) rounds (10-3) it seems to work reliably, still
not sure why not sometimes with round (#Teams - 2)

In the Tester() routine uncomment ApplyFormula_RankDiff (I renamed the
argument ref_ranks at the last moment so correct ref_scores in the code), if
you get #Value errors run SampleData again to recalc.

It shows individual rank differences in the pairs made by the UDF and the
"sum of the diffs" in the last row. If manually you can make a better set it
might point how to improve the main algorithm (it's not optimal).

After an initial struggle to see how to use the array formulae on the
sheet it all came right.

Glad you figured that. But don't feel it must be used only as a UDF, it
should work almost as-is if say linked to a button or a worksheet
change-event to return the results to cells, with no formulas at all.

Thanks ever so much. It certainly will make the running of a Swiss Teams
a pleasure in the future.
However, I am sure that I will be tweaking it some more before releasing.

Releasing? Not sure what you mean, publishing? but certainly need to test
thoroughly and correct/improve before using for real. Implementing and
integrating as something usable though is different.

If you would like to have a copy of the finished product for use at your
bridge club, feel free to ask.

Sure (though I don't play bridge yet alone in a bridge club), I've just sent
you an email to your address above.

Regards,
Peter T