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

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