Unique Random Numbers
"Paul Black" wrote:
I have tried to adapt the code slightly to have two input boxes pop up
initially, the first asking the maximum number to be Randomized and
the second to ask how many numbers there are in each combination.
[....]
nFrom = Application.InputBox("How Many Numbers Would You Like To
Randomize?",
"Shuffle Size", Type:=1)
nDrawn = Application.InputBox("How Many Numbers In Each Combination?",
"Combination Size", Type:=1)
Try the macro below.
-----
Option Explicit
Sub Shuffle()
' ***** customize*****
Const rAddress As String = "b2"
Const clrAddress As String = "b:k"
' *****
Dim i As Long, j As Long
Dim nPool As Long, nCol As Long, nRow As Long
Dim r As Range
Randomize
nPool = Application.InputBox("How Many Numbers Would You " & _
"Like To Randomize?", "Shuffle Size", Type:=1)
If nPool <= 0 Then End
nCol = Application.InputBox("How Many Numbers In Each " & _
"Combination?", "Combination Size", Type:=1)
If nCol <= 0 Then End
' determine range of output.
If nCol nPool Then nCol = nPool
nRow = Int((nPool + nCol - 1) / nCol) ' round up
Set r = Range(rAddress).Resize(nRow, nCol)
' clear any previous data
Columns(clrAddress).ClearContents
' initialize pool of numbers for random drawings
ReDim num(1 To nPool) As Long
For i = 1 To nPool: num(i) = i: Next
For i = 1 To nPool
' draw next random number.
' store into range, across columns first,
' then down rows
j = 1 + Int(nPool * Rnd())
r(i) = num(j)
' remove num(j) from pool of numbers
If j < nPool Then num(j) = num(nPool)
nPool = nPool - 1
Next
End Sub
|