Random Number generation to create a cup draw

[mcconns]

Aim is to create a random cup draw.

I enter 32 players names in cells A1 - A32

I want to generate random numbers between 1 and 32. At no time should any random number generated be repeated.

In addition when each random number is generated I want it to recognise a players name and copy his name into say cell C1.

The next random number generated should follow the above process but this players name should be copied in cell E1.

Next name to cell C2, followed by cell E2 and so on until we have 16 players names in cells C1-C16 and 16 players names in cells E1-E16

 

[Escalus]

Try this :-

Sub Randomize_List()
Application.ScreenUpdating = False
[A1:A32].Copy [C1]
Columns("C:D").Insert
[D1:D32].FormulaR1C1 = "=RAND()"
[D1:E32].Sort Key1:=[D1], Header:=xlNo
[D1:D32].Value = [D1:D32].Value
[C1:C32].FormulaR1C1 = "=IF(MOD(ROW(),2)<>0,1,2)"
[C1:C32].Value = [C1:C32].Value
[C1:E32].Sort Key1:=[C1], Header:=xlNo
[E17:E32].Cut
ActiveSheet.Paste Destination:=[G1]
Columns("C:D").Delete
End Sub
This message was edited by Escalus on 2002-03-08 02:35

 

[Dave Hawley]

Hi mcconns

Here is some that will create random numbers for.


Sub RandomNumberGenerator()
'Creates a list of random numbers _
between 1 and 36 in range A1:F6
'Written by OzGrid Business Applications
'www.ozgrid.com
Dim Rw As Integer, Col As Integer
Dim Reply1 As Long, Reply2 As Long, Reply3 As Long
Dim lSqR As Long
Dim lSqC As Long
Dim i As Long, lRand As Long
On Error Resume Next




Above:
Reply2 = 0
Reply2 = InputBox("Lowest number ?" _
& Chr(13) & Chr(13) & "Number must be greater than 0 and entered without spaces or commas" & Chr(13) _
, "OzGrid Random Number Generator", 1)
If Reply2 = 0 Then Exit Sub

If Reply2 < 1 Then
MsgBox "Number must be greater than 0", vbCritical, "OzGrid Business Applications"
GoTo Above
End If

Above2:
Reply3 = 0
Reply3 = InputBox("Highest number ? " _
& Chr(13) & Chr(13) & "Number must be greater than " & Reply2 & " and entered without spaces or commas" & Chr(13) _
, "Lowest number = " & Reply2, 500)
If Reply3 = 0 Then Exit Sub

If Reply3 <= Reply2 Then
MsgBox "Number must be greater than " & Reply2, vbCritical, "OzGrid Business Applications"
GoTo Above2
End If


HowMany:
Reply1 = 0
Reply1 = InputBox("How many random numbers do you wish to generate?" _
& Chr(13) & Chr(13) & "Number must be whole and less than 1000" & Chr(13) _
& Chr(13) & "An amount greater than 500 within a tight band will take some time!" _
& Chr(13) & "Numbers will be sorted Left to Right by row" _
, "Lowest number = " & Reply2 & " Highest number = " & Reply3, 200)
If Reply1 = 0 Then Exit Sub

If Reply1 > 1000 Then
MsgBox "Number must be less than 1000", vbCritical, "OzGrid Business Applications"
GoTo HowMany:
End If

If Reply1 > Reply3 - Reply2 Then
MsgBox "Not possible.", vbCritical, "OzGrid Business Applications"
GoTo HowMany:
End If

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Sheets.Add().Name = "Random Numbers"
If ActiveSheet.Name <> "Random Numbers" Then
ActiveSheet.Delete
Sheets("Random Numbers").Select
Cells.Clear
End If
Dim sCheck As String
Range("A1") = Reply1

Range("B1").FormulaR1C1 = "=ROUNDUP(SQRT(RC[-1]),0)"




lSqR = Range("B1")
lSqC = lSqR

On Error GoTo 0
'Clear the range ready for random numbers
Range("A1:IV600").Clear

Randomize ' Initialize random-number generator.
For Col = 1 To lSqC 'Set the Column numbers
If WorksheetFunction.CountA(Cells) = Reply1 Then Exit For
For Rw = 1 To lSqR 'Set the Row numbers
If WorksheetFunction.CountA(Cells) = Reply1 Then Exit For

'Cells(Rw, Col) = Int((Reply3 - Reply2 + 1) * Rnd + Reply2)

Do Until WorksheetFunction.CountIf _
(Cells, Cells(Rw, Col)) = 1
Cells(Rw, Col) = Int((Reply3 - Reply2 + 1) * Rnd + Reply2)
Loop
If WorksheetFunction.CountA(Cells) = Reply1 Then Exit For
Next Rw
If WorksheetFunction.CountA(Cells) = Reply1 Then Exit For
Next Col

Rw = 1
For Rw = 1 To ActiveSheet.UsedRange.Rows.Count
Rows(Rw).Sort Key1:=Rows(Rw).Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
Next Rw
Application.Goto Range("A1"), True

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[Ian Mac]

Here's a formula solution,

in A1:A32 put:

=Rand() (place in A1 & copy down)

in B1:B32 put:

=RANK(A1,$A$1:$A$32)+COUNTIF(B$1:B1,B1)-1
Exactly as it's writtem with the $'s in the same places.

in C1 put:

your Players Names

Now in any column you want (I'm using E), put the numbers 1 - 16, then 2 columns along from that (G for me) put 17 - 32.

now all you need to do is use vlookup in cols F + H on the table you've just created range B1:C32.

the easiest way is to put:

=VLOOKUP(E1,$B$1:$C$32,2,0)

in F1 and copy down. then copy paste F1:F16 into H1:H16. (again make sure the $'s are in the right place).

you can now hide Cols B,C,E and G. Every time you press Del, F9 or recalc the sheet you'll get a random list of matches.

Hope this helps.

 

[Escalus]

On 2002-03-08 04:46, Ian Mac wrote:
Here's a formula solution,

in A1:A32 put:

=Rand() (place in A1 & copy down)

in B1:B32 put:

=RANK(A1,$A$1:$A$32)+COUNTIF(B$1:B1,B1)-1
Exactly as it's writtem with the $'s in the same places.

in C1 put:

your Players Names

Now in any column you want (I'm using E), put the numbers 1 - 16, then 2 columns along from that (G for me) put 17 - 32.

now all you need to do is use vlookup in cols F + H on the table you've just created range B1:C32.

the easiest way is to put:

=VLOOKUP(E1,$B$1:$C$32,2,0)

in F1 and copy down. then copy paste F1:F16 into H1:H16. (again make sure the $'s are in the right place).

you can now hide Cols B,C,E and G. Every time you press Del, F9 or recalc the sheet you'll get a random list of matches.

Hope this helps.

The macro I posted is also based on recorded code from the following :-

- Players names in A1:A32
- Copy players names to C1:C32
- Insert 2 columns before column C
- In D1:D32 enter =RAND()
- Convert D1:D32 to values
- Select D1:E32 and sort
- In C1:C32 enter =IF(MOD(ROW(),2)<>0,1,2)
- Convert C1:C32 to values
- Select C1:C32 and sort
- Cut E17:E32 and paste to G1
- Delete columns C:D