12/04/2014

Generate a Unique Random id on a range of cells - Simple Random Sample

Generate a Unique Random id on a range of cells

Hi this is my method to assign a unique random number whithin the desired range of values to each of the cells in the selected Range.

The uniqueRandomLongMethods has been copied from http://www.cpearson.com/excel/randomnumbers.aspx

Cheers

 Public Sub attributeRandomRange()  
 Dim myArray As Variant  
 Dim i As Integer  
 Dim requiredRange As Range  
 Dim startRnd As Long  
 Dim endRnd As Long  
 Set requiredRange = Selection  
 startRnd = 1  
 endRnd = 36  
   If (requiredRange.Count > (endRnd - startRnd)) Then  
     GoTo error  
     Exit Sub  
   Else  
     myArray = UniqueRandomLongs(startRnd, endRnd, requiredRange.Count)  
     i = 1  
     For Each Cell In requiredRange.Cells  
       Cell.Value = myArray(i)  
       i = i + 1  
     Next  
   End If  
 Exit Sub  
 error:  
 MsgBox "The range is bigger than the possible distinct random values", _  
   vbExclamation + vbOKCancel, _  
   "Error: " & CStr(Err.Number)  
 End Sub  
 Public Function UniqueRandomLongs(Minimum As Long, Maximum As Long, _  
       Number As Long, Optional ArrayBase As Long = 1, _  
       Optional Dummy As Variant) As Variant  
 Dim SourceArr() As Long  
 Dim ResultArr() As Long  
 Dim SourceNdx As Long  
 Dim ResultNdx As Long  
 Dim TopNdx As Long  
 Dim Temp As Long  
 If Minimum > Maximum Then  
   UniqueRandomLongs = Null  
   Exit Function  
 End If  
 If Number > (Maximum - Minimum + 1) Then  
   UniqueRandomLongs = Null  
   Exit Function  
 End If  
 If Number <= 0 Then  
   UniqueRandomLongs = Null  
   Exit Function  
 End If  
 Randomize  
 ''''''''''''''''''''''''''''''''''''''''''''''  
 ReDim SourceArr(Minimum To Maximum)  
 ReDim ResultArr(ArrayBase To (ArrayBase + Number - 1))  
 For SourceNdx = Minimum To Maximum  
   SourceArr(SourceNdx) = SourceNdx  
 Next SourceNdx  
 TopNdx = UBound(SourceArr)  
 For ResultNdx = LBound(ResultArr) To UBound(ResultArr)  
   SourceNdx = Int((TopNdx - Minimum + 1) * Rnd + Minimum)  
   ResultArr(ResultNdx) = SourceArr(SourceNdx)  
   Temp = SourceArr(SourceNdx)  
   SourceArr(SourceNdx) = SourceArr(TopNdx)  
   SourceArr(TopNdx) = Temp  
   TopNdx = TopNdx - 1  
 Next ResultNdx  
 UniqueRandomLongs = ResultArr  
 End Function  

No comments:

Post a Comment