Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Old April 19th 05, 12:03 PM
Frazer Snowdon
 
Posts: n/a
Default Creating fixture lists

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


  #2   Report Post  
Old April 19th 05, 12:28 PM
Bob Phillips
 
Posts: n/a
Default

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").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



  #3   Report Post  
Old April 19th 05, 01:14 PM
Bob Phillips
 
Posts: n/a
Default

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").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").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





  #4   Report Post  
Old April 19th 05, 01:28 PM
Bob Phillips
 
Posts: n/a
Default

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").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").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").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







  #5   Report Post  
Old April 20th 05, 08:15 AM
Frazer Snowdon
 
Posts: n/a
Default

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").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").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").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










  #6   Report Post  
Old April 20th 05, 09:34 AM
Bob Phillips
 
Posts: n/a
Default

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").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").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").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










  #7   Report Post  
Old April 20th 05, 12:54 PM
Frazer Snowdon
 
Posts: n/a
Default

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").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").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").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











  #8   Report Post  
Old April 20th 05, 02:32 PM
Bob Phillips
 
Posts: n/a
Default

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").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").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").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













  #9   Report Post  
Old April 20th 05, 03:45 PM
Frazer Snowdon
 
Posts: n/a
Default

Bob,

That's a very kind offer - won't it take you a long time? As I said, there
are almost 250 teams across 21 leagues, some with different numbers of teams
in.

I'm not sure which teams are in which league yet because the current season
hasn't finished just yet. But I may take you up on your offer when it has.
Thanks very much.

What's your e-mail address?

Frazer


"Bob Phillips" wrote:

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").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").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").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














  #10   Report Post  
Old April 20th 05, 04:15 PM
Bob Phillips
 
Posts: n/a
Default

Frazier,

I will create a workbook that does it based upon whatever teams are in a
given range, and then you can just plug one set of teams in, generate a
fixture list, then the next and so on. You can do that whenever you are
ready.

Give me your email address and I will mail it on.

--

HTH

RP
(remove nothere from the email address if mailing direct)


"Frazer Snowdon" wrote in message
...
Bob,

That's a very kind offer - won't it take you a long time? As I said, there
are almost 250 teams across 21 leagues, some with different numbers of

teams
in.

I'm not sure which teams are in which league yet because the current

season
hasn't finished just yet. But I may take you up on your offer when it has.
Thanks very much.

What's your e-mail address?

Frazer


"Bob Phillips" wrote:

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").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").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").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


















Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Creating "factorial" result from three lists... Phil Excel Discussion (Misc queries) 3 February 25th 05 10:15 PM
Eliminate creating list that returns blank cells Marc Todd Excel Worksheet Functions 1 January 26th 05 10:58 PM
Comparing 2 Customer Lists to Identify Shared Customers carl Excel Worksheet Functions 2 January 26th 05 08:17 PM
Creating Combinations from Two Lists jlburak Excel Discussion (Misc queries) 3 December 16th 04 12:21 AM
Aligning Two Lists in Excel Rich Excel Discussion (Misc queries) 2 December 4th 04 06:44 PM


All times are GMT +1. The time now is 08:25 AM.

Powered by vBulletin® Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright 2004-2020 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Copyright © 2017