Home 
Search 
Today's Posts 
#1




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




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




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




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 n1, 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




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 n1, 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




Yes it is easy.
In a worksheet, hit AltF11. 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 n1, 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




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 AltF11. 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 n1, 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




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 AltF11. 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 n1, 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




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 email 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 AltF11. 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 n1, 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




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 email 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 AltF11. 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 n1, 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 
Display Modes  


Similar Threads  
Thread  Forum  
Creating "factorial" result from three lists...  Excel Discussion (Misc queries)  
Eliminate creating list that returns blank cells  Excel Worksheet Functions  
Comparing 2 Customer Lists to Identify Shared Customers  Excel Worksheet Functions  
Creating Combinations from Two Lists  Excel Discussion (Misc queries)  
Aligning Two Lists in Excel  Excel Discussion (Misc queries) 