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
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
Public Sub attributeRandomRange()
Dim myArray As Variant
Dim i As Integer
Dim requiredRange As Range
Set requiredRange = Selection
myArray = UniqueRandomLongs(1, requiredRange.Count, requiredRange.Count)
i = 1
For Each Cell In requiredRange.Cells
Cell.Value = myArray(i)
i = i + 1
Next
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
Here I ran the code 3 times. First for A1:A17, then for B1:B17 then C1:C17.
Cheers
your code has a error.it drops 1 random number,it works OK if you enter the values into function ie
ReplyDelete(1,90,90) min,max,number
Thank you! I updated my code.
Delete