A small project

[Bigjayce]

Hey Guys and gals,

I run a small football (or soccer ) club and ever week I have to pick
random teams.

I would like to have a small VBA routine that has a button on my main
excel screen and when clicked will take the 14 players and randomise
them into 2 groups of 7.

Someone did say use the randomise function but I'd like it so if I am
not happy with the results I can just click and run it again.

Can anyone help ???

Jayce

 

[Harald Staff]

Hi Jayce

Open the VB editor (Alt F11 or similar). Insert > Module (with that menu).
Paste this in:

Option Explicit

Type Player
D As Double
S As String
End Type

Sub ShufflePlayers()
Dim Players() As Player
Dim Tmp As Player
Dim R As Range
Dim R2 As Range
Dim Cel As Range
Dim L As Long
Dim M As Long
'select players
Set R = Application.InputBox("Select your contestants:", _
Default:=Selection.Address, _
Type:=8)
If R Is Nothing Then Exit Sub
ReDim Players(1 To Selection.Count)
Randomize
L = 0
'attatch a random number to each:
For Each Cel In R
L = L + 1
Players(L).D = Rnd()
Players(L).S = Cel.Value
Next
'sort by those numbers:
For L = 1 To UBound(Players) - 1
For M = 1 To UBound(Players) - 1
If Players(M).D > Players(M + 1).D Then
Tmp.D = Players(M + 1).D
Tmp.S = Players(M + 1).S
Players(M + 1).D = Players(M).D
Players(M + 1).S = Players(M).S
Players(M).D = Tmp.D
Players(M).S = Tmp.S
End If
Next
Next
'paste the result:
Set R2 = Application.InputBox("Where should I paste this ?:", _
Default:=Selection(1).Offset(0, 2).Address, _
Type:=8)
If R2 Is Nothing Then Exit Sub
If R2.Count <> R.Count Then Set R2 = R2(1).Resize(R.Count, 1)
L = 0
For Each Cel In R2
L = L + 1
Cel.Value = Players(L).S
Next
End Sub

Now it's ready to run. Return to Excel and test.

HTH. Best wishes Harald

 

[Harald Staff]

Oops. Put
On Error Resume Next
between
'select players
and
Set R = ...

Best wishes Harald

Hi Jayce

Open the VB editor (Alt F11 or similar). Insert > Module (with that menu).
Paste this in:

Option Explicit

Type Player
D As Double
S As String
End Type

Sub ShufflePlayers()
Dim Players() As Player
Dim Tmp As Player
Dim R As Range
Dim R2 As Range
Dim Cel As Range
Dim L As Long
Dim M As Long
'select players
Set R = Application.InputBox("Select your contestants:", _
Default:=Selection.Address, _
Type:=8)
If R Is Nothing Then Exit Sub
ReDim Players(1 To Selection.Count)
Randomize
L = 0
'attatch a random number to each:
For Each Cel In R
L = L + 1
Players(L).D = Rnd()
Players(L).S = Cel.Value
Next
'sort by those numbers:
For L = 1 To UBound(Players) - 1
For M = 1 To UBound(Players) - 1
If Players(M).D > Players(M + 1).D Then
Tmp.D = Players(M + 1).D
Tmp.S = Players(M + 1).S
Players(M + 1).D = Players(M).D
Players(M + 1).S = Players(M).S
Players(M).D = Tmp.D
Players(M).S = Tmp.S
End If
Next
Next
'paste the result:
Set R2 = Application.InputBox("Where should I paste this ?:", _
Default:=Selection(1).Offset(0, 2).Address, _
Type:=8)
If R2 Is Nothing Then Exit Sub
If R2.Count <> R.Count Then Set R2 = R2(1).Resize(R.Count, 1)
L = 0
For Each Cel In R2
L = L + 1
Cel.Value = Players(L).S
Next
End Sub

Now it's ready to run. Return to Excel and test.

HTH. Best wishes Harald

 

[Bigjayce]

WOW Thanks harold

quick question, I have a list in an excel spreadsheet of the player
names - could this be modded to look at that list and jumble them up ?

Jayc

 

[Harald Staff]

Yes. Need more detail for a suggestion though. Is it in the same workbook as
the code ? If not, is the file open ? Which sheet and range is the list ?

 

[Bigjayce]

would I be able to send the sheet directly to you so you have it i
front of you

 

[Bigjayce]

On the sheet I have a list of names in b3:b16

There is a button on the sheet saying 'Pick Teams'

Team one needs to go in f24:f30 and team two in g24:g30

Hope this helps :

 

[Harald Staff]

Try hstf at hotmail dot com, and I'll try to look into it. Please zip it
first if possible.

Best wishes Harald

 

[Bigjayce]

Hi Harold,

Did you recieve the file ?

Jayc

 

[Harald Staff]

Hi Harold,

Did you recieve the file ?

Yes. I'll look at it as soon as possible. (Some tasks have higher priority
by default, sorry ;-)

Best wishes Harald

 

[Harald Staff]

Solution emailed.

Harald

 

[Bigjayce]

and greatly appriciated :