Unique Random Numbers using VBA

Question

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

Answer 1

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.

Answer 2

I see you have an accepted answer, but for whatever it's worth here is my stab at this question. This one uses a boolean function instead of numerical arrays. It's very simple yet fast. The advantage of it, which I'm not saying is perfect, is an effective solution for numbers in a long range because you only ever check the numbers you have already picked and saved and don't need a potentially large array to hold the values you have rejected so it won't cause memory problems because of the size of the array.

Sub UniqueRandomGenerator()
Dim N As Long, MaxNum As Long, MinNum As Long, Rand As Long, i As Long

MinNum = 1        'Put the input of minimum number here
MaxNum = 100      'Put the input of maximum number here
N = MaxNum - MinNum + 1

ReDim Unique(1 To N, 1 To 1)

For i = 1 To N
Randomize         'I put this inside the loop to make sure of generating "good" random numbers
    Do
        Rand = Int(MinNum + N * Rnd)
        If IsUnique(Rand, Unique) Then Unique(i, 1) = Rand:  Exit Do
    Loop
Next
Sheet1.[A1].Resize(N) = Unique
End Sub

Function IsUnique(Num As Long, Data As Variant) As Boolean
Dim iFind As Long

On Error GoTo Unique
iFind = Application.WorksheetFunction.Match(Num, Data, 0)

If iFind > 0 Then IsUnique = False: Exit Function

Unique:
    IsUnique = True
End Function

Answer 3

It Works perfectly:

Option Base 1
Public Function u(a As Variant, b As Variant) As Variant
 Application.Volatile
 Dim k%, p As Double, flag As Boolean, x() As Variant
    k = 1
  flag = False
  ReDim x(1)
   x(1) = Application.RandBetween(a, b)
  Do Until k = b - a + 1

   Do While flag = False
   Randomize
    p = Application.RandBetween(a, b)
     'Debug.Assert p = 2
    resultado = Application.Match(p, x, False)
     If IsError(resultado) Then
      k = k + 1
      ReDim Preserve x(k)
      x(k) = p
       flag = True
      Else
       flag = False
      End If
   Loop
   flag = False
  Loop
  u = x
End Function

Answer 4

Function RandLotto(Bottom As Integer, Top As Integer, _

                    Amount As Integer) As String

    Dim iArr As Variant

    Dim i As Integer

    Dim r As Integer

    Dim temp As Integer



    Application.Volatile



    ReDim iArr(Bottom To Top)

    For i = Bottom To Top

        iArr(i) = i

    Next i



    For i = Top To Bottom + 1 Step -1

        r = Int(Rnd() * (i - Bottom + 1)) + Bottom

        temp = iArr(r)

        iArr(r) = iArr(i)

        iArr(i) = temp

    Next i



    For i = Bottom To Bottom + Amount - 1

        RandLotto = RandLotto & " " & iArr(i)

    Next i



    RandLotto = Trim(RandLotto)



End Function