can this macro be adapted for 4 groups?

  • Thread starter Thread starter Martyn
  • Start date Start date
M

Martyn

Hi,
Below is a code from Jim Cone which provides a way of drawing arbitrary
names from a bag.
I need to adopt this code such that it can be used to establish 4 groups
(A,B,C and D each having 4 teams) out of 16 team. The only problem is that I
need to select 4 teams out of the 16 team before I start drawing. Can you
suggest solutions?
TIA
==============================
'July 06, 2004 - Jim Cone
Sub DisplayRandomNames()
Dim RS As Long
Dim objRangeA As Range
Dim objRangeB As Range
Dim objRangeC As Range
Dim blnNotThere As Boolean

' Establish where everything goes or comes from.
Set objRangeA = Worksheets(1).Range("A1:A35")
Set objRangeB = Worksheets(2).Range("B1:B35")
Set objRangeC = Worksheets(2).Range("C1:C35")

' Is there anything to work with?
If WorksheetFunction.CountA(objRangeA) < 35 Then
MsgBox "Kaynak listenin eksik olduðu sayfa " & objRangeA.Parent.Name &
" ", _
vbExclamation, " Maksimum 35 olmalýydý"
GoTo DontCallMe
End If

Worksheets(2).Select
StartOver:
' If objRangeC range is blank then fill
' with names, clear Columns 1 and 2 and exit.
If WorksheetFunction.CountA(objRangeC) = 0 Then
objRangeC.Value = objRangeA.Value
objRangeC.Columns.AutoFit
objRangeB.ClearContents
objRangeB.ColumnWidth = objRangeC.ColumnWidth
'Range("A1").ClearContents
Range("A1").ColumnWidth = objRangeC.ColumnWidth
GoTo DontCallMe
End If

' Keep looking until random name is found in objRangeC.
Do While blnNotThere = False
Randomize
RS = Int(Rnd * 35 + 1)
'Find RS position within objRangeC.
If Not IsError(Application.Match(objRangeC(RS), objRangeC, 0)) Then
blnNotThere = True
Range("A1").Value = objRangeC(RS)
objRangeB(WorksheetFunction.CountA(objRangeB) + 1).Value =
objRangeC(RS)
objRangeC(Application.Match(objRangeC(RS), objRangeC, 0)).Delete
shift:=xlUp
End If
Loop

' Are you bored yet?
If WorksheetFunction.CountA(objRangeC) = 0 Then
If MsgBox("Ýþlem Tamam! .. Tekrar? ", vbQuestion + vbYesNo, _
" Rastgele isim Kurasý") = vbYes Then GoTo StartOver
End If

DontCallMe:
Set objRangeA = Nothing
Set objRangeB = Nothing
Set objRangeC = Nothing
End Sub
 
Martyn,

I never knew I was bilingual. <g>
I decided the code you are trying to use wasn't very adaptable, so I started to write a _
new routine and it just kept growing.
I assume you use five columns on your worksheet:
the master team list and the four individual teams.
The code will only work if you use the same ranges I use or if you change the code.
Regards,
Jim Cone
San Francisco, CA

'-----------------------------------------------
Sub CreateRandomTeams()
'Jim Cone - San Francisco, CA - August 20, 2004
Dim objTeamOne As Range
Dim objTeamTwo As Range
'Dim objTeamThree As Range - Not required in code
Dim objTeamFour As Range
Dim objAllTeams As Range
Dim strName As String
Dim arrOne(1 To 16) As Long
Dim colNames As Collection
Dim i As Long
Dim j As Long
Dim N As Long
Dim M As Long

'User fills this range with the names of all 16 teams
Set objAllTeams = Range("B5:B20")

'User fills this range with names of the first team
Set objTeamOne = Range("D5:D8")

'The next three ranges are filled at random 'from the remaining 12 team names.
Set objTeamTwo = Range("E5:E8")
' objTeamThree = Range("F5:F8") ' not required in code
Set objTeamFour = Range("G5:G8")

'Check if properly set up
If WorksheetFunction.CountA(objAllTeams) <> 16 Or _
WorksheetFunction.CountA(objTeamOne) <> 4 Then
MsgBox "Teams names are missing. ", vbOKOnly + vbExclamation, " Select Teams Program"
GoTo NoTeamWork

Else

' Check if duplicate names exist
Set colNames = New Collection
On Error Resume Next
For N = 1 To 4
colNames.Add vbNullString, objTeamOne(N)
Next 'N
On Error GoTo 0

If colNames.Count <> 4 Then
strName = "Duplicate names exist in the first team. "
Else
For N = 4 To 1 Step -1
colNames.Remove N
Next 'N

On Error Resume Next
For N = 1 To 16
colNames.Add vbNullString, objAllTeams(N)
Next 'N
On Error GoTo 0
If colNames.Count <> 16 Then _
strName = "Duplicate names exist in the master list. "
End If

If Len(strName) Then
MsgBox strName, vbExclamation, " Select Teams Program"
GoTo NoTeamWork
End If
Set colNames = Nothing
End If

'Assign the team names at random.
For N = objTeamTwo.Column To objTeamFour.Column
j = objTeamTwo(1).Row
M = j + 4
Do While j < M
Randomize (Right(Timer, 2) * j)
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
i = Int(Rnd * 16 + 1)
If arrOne(i) <> i Then
arrOne(i) = i
strName = objAllTeams(i).Value
If IsError(Application.Match(strName, objTeamOne, 0)) Then
Cells(j, N).Value = strName
j = j + 1
End If
End If
Loop
Next 'N


NoTeamWork:
Set objAllTeams = Nothing
Set objTeamOne = Nothing
Set objTeamTwo = Nothing
Set objTeamFour = Nothing
Set colNames = Nothing
End Sub
'-----------------------------------

Martyn said:
Hi,
Below is a code from Jim Cone which provides a way of drawing arbitrary
names from a bag.
I need to adopt this code such that it can be used to establish 4 groups
(A,B,C and D each having 4 teams) out of 16 team. The only problem is that I
need to select 4 teams out of the 16 team before I start drawing. Can you
suggest solutions?
TIA
Click to expand...
- snip -
 
Martyn,

You are welcome.

Re "bilingual"...I was making a joke.
The text in the message boxes is not English.

Regards,
Jim Cone
San Francisco, CA

Martyn said:
Hi Jim,
I didn't thought of the original code writer will reply back to me on this.
Your code works like a charm.
Thanks a million.
What I couldn't figure out from your post is not the code but your comment
on bilingualizm...:)
Regards
Martyn
Click to expand...

- snip -
 
Hi Jim,
I didn't thought of the original code writer will reply back to me on this.
Your code works like a charm.
Thanks a million.
What I couldn't figure out from your post is not the code but your comment
on bilingualizm...:)
Regards
Martyn
 
Martyn said:
Hi,
Below is a code from Jim Cone which provides a way of drawing arbitrary
names from a bag.
I need to adopt this code such that it can be used to establish 4 groups
(A,B,C and D each having 4 teams) out of 16 team. The only problem is that I
need to select 4 teams out of the 16 team before I start drawing. Can you
suggest solutions?
TIA
==============================
'July 06, 2004 - Jim Cone
Sub DisplayRandomNames()
Dim RS As Long
Dim objRangeA As Range
Dim objRangeB As Range
Dim objRangeC As Range
Dim blnNotThere As Boolean

' Establish where everything goes or comes from.
Set objRangeA = Worksheets(1).Range("A1:A35")
Set objRangeB = Worksheets(2).Range("B1:B35")
Set objRangeC = Worksheets(2).Range("C1:C35")

' Is there anything to work with?
If WorksheetFunction.CountA(objRangeA) < 35 Then
MsgBox "Kaynak listenin eksik olduðu sayfa " & objRangeA.Parent.Name &
" ", _
vbExclamation, " Maksimum 35 olmalýydý"
GoTo DontCallMe
End If

Worksheets(2).Select
StartOver:
' If objRangeC range is blank then fill
' with names, clear Columns 1 and 2 and exit.
If WorksheetFunction.CountA(objRangeC) = 0 Then
objRangeC.Value = objRangeA.Value
objRangeC.Columns.AutoFit
objRangeB.ClearContents
objRangeB.ColumnWidth = objRangeC.ColumnWidth
'Range("A1").ClearContents
Range("A1").ColumnWidth = objRangeC.ColumnWidth
GoTo DontCallMe
End If

' Keep looking until random name is found in objRangeC.
Do While blnNotThere = False
Randomize
RS = Int(Rnd * 35 + 1)
'Find RS position within objRangeC.
If Not IsError(Application.Match(objRangeC(RS), objRangeC, 0)) Then
blnNotThere = True
Range("A1").Value = objRangeC(RS)
objRangeB(WorksheetFunction.CountA(objRangeB) + 1).Value =
objRangeC(RS)
objRangeC(Application.Match(objRangeC(RS), objRangeC, 0)).Delete
shift:=xlUp
End If
Loop

' Are you bored yet?
If WorksheetFunction.CountA(objRangeC) = 0 Then
If MsgBox("Ýþlem Tamam! .. Tekrar? ", vbQuestion + vbYesNo, _
" Rastgele isim Kurasý") = vbYes Then GoTo StartOver
End If

DontCallMe:
Set objRangeA = Nothing
Set objRangeB = Nothing
Set objRangeC = Nothing
End Sub
Click to expand...
 
Back
Top