View Single Post
  #4   Report Post  
Posted to microsoft.public.excel.programming
Rick Rothstein \(MVP - VB\)[_1742_] Rick Rothstein \(MVP - VB\)[_1742_] is offline
external usenet poster
 
Posts: 1
Default Formula to choose X number of unique random cells from array?

I forgot to mention, you also need to change the worksheet's name in the
With statement from the "Sheet4" example name I used to the actual name of
your worksheet.

You could, if you wanted more flexibility, remove the Const statements and
the hard coded worksheet name from the code area and create an argument list
for the GetUniqueNames macro (the changing it to a normal subroutine) and
then, in a separate macro, simply call that GetUniqueNames subroutine
passing in the arguments for that particular run of your macro.

Rick

"Rick Rothstein (MVP - VB)" wrote in
message ...
Copy/Paste the code below my signature into your worksheet's code window.
The RandomizeArray subroutine takes an array and shuffles its contents
around randomly so that you can simply read off the top so many elements
of the shuffled array to guarantee that you have that many unique,
randomly selected items. The GetUniqueNames macro performs the necessary
call to the RandomizeArray subroutine so you don't have to do anything
except set your worksheet parameters in its various Const(ant) statement.

Rick

'******************* Start Of Code *******************
Sub GetUniqueNames()
Dim X As Long
Dim LastRow As Long
Dim Names() As String
Const NamesInColumn As String = "A"
Const NamesInStartRow As Long = 1
Const NamesOutColumn As String = "B"
Const NamesOutStartRow As Long = 1
Const NumberNamesToReturn As Long = 50
With Worksheets("Sheet4")
LastRow = .Cells(.Rows.Count, NamesInColumn).End(xlUp).Row
ReDim Names(0 To LastRow - NamesInStartRow)
For X = NamesInStartRow To LastRow
Names(X - NamesInStartRow) = .Cells(X, NamesInColumn).Value
Next
RandomizeArray Names
For X = NamesOutStartRow To NamesOutStartRow + NumberNamesToReturn - 1
.Cells(X, NamesOutColumn).Value = Names(X)
Next
End With
End Sub

Sub RandomizeArray(ArrayIn As Variant)
Dim X As Long
Dim RandomIndex As Long
Dim TempElement As Variant
Static RanBefore As Boolean
If Not RanBefore Then
RanBefore = True
Randomize
End If
If VarType(ArrayIn) = vbArray Then
For X = UBound(ArrayIn) To LBound(ArrayIn) Step -1
RandomIndex = Int((X - LBound(ArrayIn) + 1) * _
Rnd + LBound(ArrayIn))
TempElement = ArrayIn(RandomIndex)
ArrayIn(RandomIndex) = ArrayIn(X)
ArrayIn(X) = TempElement
Next
Else
'The passed argument was not an array
'Put error handler here, such as . . .
Beep
End If
End Sub
'******************* End Of Code *******************



"Techhead" wrote in message
...
How would I create a formula to choose X number of unique cells from
an array? For example,

A1 = Bob
A2 = Mary
A3 = Bill
A4 = Tom
A5 = Dick


I need to choose at random, 3 of these names and they have to be
unique. On a larger scale, I have a database of 1500 names and I need
to select 50 unique names (cells) at random.

Thanks,
Brian