Frazier,
Send me a list of teams, your email address, and I will build you a working
workbook.
--
HTH
RP
(remove nothere from the email address if mailing direct)
"Frazer Snowdon" wrote in message
...
Thanks, Bob.
I did what you said but it errored, even with the chevrons taken out. Not
sure which bits to leave in and which to take out.
I think my best bet may be to explore other options/programmes, because I
have around 250 teams over 21 leagues to sort out and I can't afford to
get
it wrong.
I'm not doubting what you say, but I can't be coming on here to ask for
help
every time something goes wrong! It'd take me until next season to sort
it!
Thanks for your time anyway!
FS
"Bob Phillips" wrote:
Yes it is easy.
In a worksheet, hit Alt-F11. This will take you into the VBE.
In the Menu select InsertModule
Copy the code into the pane presented
Then on the worksheet, list the teams in A1:An
Then run the macro, menu ToolsMacro..Macros, select RoundRobin from
the
list and click Run, you will get fixtures.
--
HTH
RP
(remove nothere from the email address if mailing direct)
"Frazer Snowdon" wrote in
message
...
Bob,
Many thanks for your answers, but it means nothing to me. I'm not a
programmer, and I'm a relative newbie with Excel.
Is it easy for a beginner to do, or will I be best delegating the job
to
someone else?
cheers,
FS
"Bob Phillips" wrote:
Forget a pair of parentheses. Added some comments
Sub RoundRobin()
'Controlling procedure
'Reads the teams into an array, and loops each fixture set
'to get a new team set order and the create a set of fixtures
'from that which are then dumped onto a worksheet area
Dim varr As Variant
Dim varr1(1 To NumTeams \ 2, 1 To 2)
Range("C:D").ClearContents
varr = Worksheets("Sheet1").Range("A1:A" & NumTeams)
For i = 1 To (NumTeams - 1) * ((NumTeams \ 2) + 1) Step
(NumTeams \
2) +
1
rotate varr
Split1 varr, varr1
Cells(i, 3).Resize((NumTeams \ 2), 2).Value = varr1
Next
Set rng = Cells(Rows.Count, 3).End(xlUp)(2)
Range(Range("C1"), rng).Copy rng.Offset(1, 1)
Range(Range("D1"), rng.Offset(0, 1)).Copy rng.Offset(1, 0)
End Sub
Sub Split1(arr1, arr2)
'This procedure creates one fixture set by coupling element 1
'of the input array with element n, element 2 with n-1, etc.,
'and returns this as a new array
l = -1
For i = 1 To NumTeams
If i <= (NumTeams \ 2) Then
j = i
ii = i
k = 1
Else
l = l + 1
ii = NumTeams - l
j = i - (NumTeams \ 2)
k = 2
End If
arr2(j, k) = arr1(ii, 1)
Next
End Sub
Sub rotate(arr)
'This procedure shunts all except the first elements of
'the array up by 1 and moves the second element to last
Dim aryRotate
aryRotate = arr
For i = 2 To NumTeams - 1
arr(i, 1) = aryRotate(i + 1, 1)
Next
arr(NumTeams, 1) = aryRotate(2, 1)
End Sub
--
HTH
RP
(remove nothere from the email address if mailing direct)
"Bob Phillips" wrote in message
...
PS this was for fourteen teams, here is a more generalised version
for
any
number of teams. It assumes an even number of teams, so if you
have an
odd
number, just add a dummy team then delete their fixtures (I am
sure
that
it
could manage even or odd, but I don't have the inclination :-))
Const NumTeams As Long = 16
Sub RoundRobin()
Dim varr As Variant
Dim varr1(1 To NumTeams \ 2, 1 To 2)
Range("C:D").ClearContents
varr = Worksheets("sheet1").Range("A1:A" & NumTeams)
For i = 1 To (NumTeams - 1) * (NumTeams \ 2) + 1 Step (NumTeams \
2) +
1
rotate varr
Split1 varr, varr1
Cells(i, 3).Resize((NumTeams \ 2), 2).Value = varr1
Next
Set rng = Cells(Rows.Count, 3).End(xlUp)(2)
Range(Range("C1"), rng).Copy rng.Offset(1, 1)
Range(Range("D1"), rng.Offset(0, 1)).Copy rng.Offset(1, 0)
End Sub
Sub Split1(arr1, arr2)
l = -1
For i = 1 To NumTeams
If i <= (NumTeams \ 2) Then
j = i
ii = i
k = 1
Else
l = l + 1
ii = NumTeams - l
j = i - (NumTeams \ 2)
k = 2
End If
arr2(j, k) = arr1(ii, 1)
Next
End Sub
Sub rotate(arr)
arr1 = arr
For i = 2 To NumTeams - 1
arr(i, 1) = arr1(i + 1, 1)
Next
arr(NumTeams, 1) = arr1(2, 1)
End Sub
--
HTH
RP
(remove nothere from the email address if mailing direct)
"Bob Phillips" wrote in
message
...
Here is a solution that was previously given by Tom Ogilvy.
Just mix up the combinations and assign dates.
Sub RoundRobin14()
Dim varr As Variant
Dim varr1(1 To 7, 1 To 2)
Range("C:D").ClearContents
varr = Worksheets("sheet1").Range("A1:A14")
For i = 1 To 13 * 8 Step 8
rotate varr
Split1 varr, varr1
Cells(i, 3).Resize(7, 2).Value = varr1
Next
Set rng = Cells(Rows.Count, 3).End(xlUp)(2)
Range(Range("C1"), rng).Copy rng.Offset(1, 1)
Range(Range("D1"), rng.Offset(0, 1)).Copy rng.Offset(1, 0)
End Sub
Sub Split1(arr1, arr2)
l = -1
For i = 1 To 14
If i <= 7 Then
j = i
ii = i
k = 1
Else
l = l + 1
ii = 14 - l
j = i - 7
k = 2
End If
arr2(j, k) = arr1(ii, 1)
Next
End Sub
Sub rotate(arr)
arr1 = arr
For i = 2 To 13
arr(i, 1) = arr1(i + 1, 1)
Next
arr(14, 1) = arr1(2, 1)
End Sub
--
HTH
RP
(remove nothere from the email address if mailing direct)
"Frazer Snowdon" wrote
in
message
...
Hi,
How can I use Excel to create fixture lists for a sporting
league?
I'm taking over the job from a colleague, but I don't know how
to
do
it.
I
know that he gives each team a value, and then gets excel to
automatically
generate the fixtures for the whole season.
Is this easily possible?
FS
|