Unique Random Numbers using VBA

excel, vba

Solution

Here's a method of guaranteeing unique integer random numbers. Inline comments describe the method.

Function UniuqeRandom(Mn As Long, Mx As Long, Sample As Long) As Long()
    Dim dat() As Long
    Dim i As Long, j As Long
    Dim tmp As Long

    ' Input validation checks here
    If Mn > Mx Or Sample > (Mx - Mn + 1) Then
        ' declare error to suit your needs
        Exit Function
    End If

    ' size array to hold all possible values
    ReDim dat(0 To Mx - Mn)

    ' Fill the array
    For i = 0 To UBound(dat)
        dat(i) = Mn + i
    Next

    ' Shuffle array, unbiased
    For i = UBound(dat) To 1 Step -1
        tmp = dat(i)
        j = Int((i + 1) * Rnd)
        dat(i) = dat(j)
        dat(j) = tmp
    Next

    'original biased shuffle
    'For i = 0 To UBound(dat)
    '    tmp = dat(i)
    '    j = Int((Mx - Mn) * Rnd)
    '    dat(i) = dat(j)
    '    dat(j) = tmp
    'Next

    ' Return sample
    ReDim Preserve dat(0 To Sample - 1)
    UniuqeRandom = dat
End Function

use it like this

Dim low As Long, high As Long

Dim rng As Range
Dim dat() As Long

Set rng = Range(Cells(1, 1), Cells(1, 1).End(xlToRight))
dat = UniuqeRandom(low, high, rng.Columns.Count)
rng.Offset(1, 0) = dat

Note: see this Wikipedia article regarding shuffle bias

The edit fixed one source of bias. The inherent limitations of `Rnd` (based on a 32 bit seed) and Modulo bias remain.

Problem

I am trying to create a series of unique (non-duplicating) random numbers within a user defined range. I have managed to create the random numbers, but I am getting duplicate values. How can I ensure that the random numbers will never be a duplicate? ``` Sub GenerateCodesUser() Application.ScreenUpdating = False Worksheets("Users").Activate Dim MINNUMBER As Long Dim MAXNUMBER As Long MINNUMBER = 1000 MAXNUMBER = 9999999 Dim Row As Integer Dim Number As Long Dim high As Double Dim Low As Double Dim i As Integer If (CustomCodes.CardNumberMin.Value = "") Then MsgBox ("Fill Card Number Field!") Exit Sub ElseIf (CustomCodes.CardNumberMin.Value < MINNUMBER) Then MsgBox ("Card Number Value must be equal or higher then" & MINNUMBER) Exit Sub End If If (CustomCodes.CardNumberMax.Value = "") Then MsgBox ("Fill Card Number Field!") Exit Sub ElseIf (CustomCodes.CardNumberMax.Value > MAXNUMBER) Then MsgBox ("Card Number Value must be equal or higher then " & MAXNUMBER) Exit Sub End If Low = CustomCodes.CardNumberMin.Value high = CustomCodes.CardNumberMax.Value '<<< CHANGE AS DESIRED If (Low < 1000) Then 'break End If For i = 1 To Cells(1, 1).End(xlToRight).Column If InStr(Cells(1, i), "CardNumber") Then Row = 2 While Cells(Row, 1) <> 0 Do Number = ((high - Low + 1) * Rnd() + Low) Loop Until Number > Low Cells(Row, i) = Number Row = Row + 1 Wend End If Next Application.ScreenUpdating = True End Sub ```

Original source