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