I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!

 

UniqRandInt

[Please notice that this page is provided just for historical purposes. You might find it an interesting example for conditional compiling. I suggest to use my UDF sbRandInt now, but if you only need positive random integers 1..n UniqRandInt still is the best fit.]

"Few things are harder to put up with than the annoyance of a good example." [Mark Twain]

Sometimes you need to create random integers without repetition.

If you need 20 random integers within range 1 .. 100, select 20 adjacent cells, enter =UniqRandInt(100) as array formula. If you need them in range 100 .. 199, enter =UniqRandInt(100)+99, in general:
=UniqRandInt(Endvalue - Startvalue + 1) + Startvalue - 1

If your random integers may occur up to 6 times, use =UniqRandInt(100,6). Please notice that the constant ALLOW_REPETITION has to be set to True.

If you need this feature in VBA programming environment then use VBUniqRandInt() as shown below.

UniqRandInt_Example

Example: Select cells A1:B3, type =UniqRandInt(6) and enter with CTRL + SHIFT + ENTER (as array formula).

Option Explicit

'If lRange >> n then set LATE_INITIALISATION to true
'For example if lRange=1000000 and if 1000 cells are selected (n=1000)
#Const LATE_INITIALISATION = False
'If random integers may occur more than once, allow repetitions
#Const ALLOW_REPETITION = True

#If ALLOW_REPETITION Then
Function UniqRandInt(ByVal lRange As Long, _
   Optional lMaxOccurence As Long = 1) As Variant
#Else
Function UniqRandInt(ByVal lRange As Long) As Variant
#End If
'Returns n unique (=non-repeating) random integers within 1..lRange,
'lRange >= n if n cells in a worksheet have been selected and the
'function has been entered as array formula (CTRL+SHIFT+ENTER).
'Set ALLOW_REPETITION = True and call with lMaxOccurences > 1 if
'random integers may occur more than once.

'Algorithm by: sulprobil http://Reverse("moc.liborplus.www") V1.02

Dim vA As Variant
Dim vR As Variant
Dim i As Long
Dim lr As Long
Dim lrow As Long
Dim lcol As Long

Application.Volatile

If TypeName(Application.Caller) <> "Range" Then
   UniqRandInt = CVErr(xlErrRef)
   Exit Function
End If

#If ALLOW_REPETITION Then
   If lMaxOccurence < 1 Then
       UniqRandInt = CVErr(xlErrNum)
       Exit Function
   End If
   lRange = lRange * lMaxOccurence
#End If

If Application.Caller.Count > lRange Then
   UniqRandInt = CVErr(xlErrValue)
   Exit Function
End If

ReDim vR(1 To Application.Caller.Rows.Count, _
               1 To Application.Caller.Columns.Count)

ReDim vA(1 To lRange)
#If Not LATE_INITIALISATION Then
   For i = 1 To lRange
       #If ALLOW_REPETITION Then
           vA(i) = Int((i - 1) / lMaxOccurence) + 1
       #Else
           vA(i) = i
       #End If
   Next i
#End If

i = 1
For lrow = 1 To UBound(vR, 1)
   For lcol = 1 To UBound(vR, 2)
       lr = Int(((lRange - i + 1) * Rnd) + 1)
       #If LATE_INITIALISATION Then
           If vA(lr) = 0 Then
               #If ALLOW_REPETITION Then
                   vR(lrow, lcol) = Int((lr - 1) / _
                        lMaxOccurence) + 1
               #Else
                   vR(lrow, lcol) = lr
               #End If
           Else
       #End If
           vR(lrow, lcol) = vA(lr)
       #If LATE_INITIALISATION Then
           End If
           If vA(lRange - i + 1) = 0 Then
               #If ALLOW_REPETITION Then
                   vA(lr) = Int((lRange - i + 1 - 1) / _
                        lMaxOccurence) + 1
               #Else
                   vA(lr) = lRange - i + 1
               #End If
           Else
       #End If
               vA(lr) = vA(lRange - i + 1)
       #If LATE_INITIALISATION Then
           End If
       #End If
       i = i + 1
   Next lcol
Next lrow

UniqRandInt = vR

End Function

#If ALLOW_REPETITION Then
Function VBUniqRandInt(lCount As Long, _
            ByVal lRange As Long, _
            Optional lMaxOccurence As Long = 1) As Variant
#Else
Function VBUniqRandInt(lCount As Long, _
            ByVal lRange As Long) As Variant
#End If
'Returns lCount unique (=non-repeating) random integers within
'1..lRange. lRange has to be >= lCount.
'Set ALLOW_REPETITION = True and call with lMaxOccurences > 1 if
'random integers may occur more than once.

'Algorithm by: sulprobil http://Reverse("moc.liborplus.www") V1.02

Dim vA As Variant
Dim vR As Variant
Dim i As Long
Dim lr As Long

Application.Volatile

#If ALLOW_REPETITION Then
   If lMaxOccurence < 1 Then
       VBUniqRandInt = CVErr(xlErrNum)
       Exit Function
   End If
   lRange = lRange * lMaxOccurence
#End If

If lCount > lRange Then
   VBUniqRandInt = CVErr(xlErrValue)
   Exit Function
End If

ReDim vR(1 To lCount)

ReDim vA(1 To lRange)
#If Not LATE_INITIALISATION Then
   For i = 1 To lRange
       #If ALLOW_REPETITION Then
           vA(i) = Int((i - 1) / lMaxOccurence) + 1
       #Else
           vA(i) = i
       #End If
   Next i
#End If

For i = 1 To lCount
   lr = Int(((lRange - i + 1) * Rnd) + 1)
   #If LATE_INITIALISATION Then
       If vA(lr) = 0 Then
           #If ALLOW_REPETITION Then
               vR(i) = Int((lr - 1) / lMaxOccurence) + 1
           #Else
               vR(i) = lr
           #End If
       Else
   #End If
       vR(i) = vA(lr)
   #If LATE_INITIALISATION Then
       End If
       If vA(lRange - i + 1) = 0 Then
           #If ALLOW_REPETITION Then
               vA(lr) = Int((lRange - i + 1 - 1) / _
                    lMaxOccurence) + 1
           #Else
               vA(lr) = lRange - i + 1
           #End If
       Else
   #End If
           vA(lr) = vA(lRange - i + 1)
   #If LATE_INITIALISATION Then
       End If
   #End If
Next i

VBUniqRandInt = vR

End Function

Sulprobil   Get it done   Contact   Disclaimer   Download