Уникальные случайные числа с использованием VBA

Question

Я пытаюсь создать серию уникальных (не дублирующих) случайных чисел в пределах определенного пользователем диапазона. Мне удалось создать случайные числа, но я получаю повторяющиеся значения. Как я могу гарантировать, что случайные числа никогда не будут дублироваться?

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

Вот метод гарантирует уникальные число случайных чисел. Встроенные комментарии описывают метод.

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 
    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 

использовать его как это

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 

Answer 2

Я вижу, у вас есть общепринятый ответ, но все, что стоит здесь мой удар в этом вопросе. В этом случае вместо числовых массивов используется логическая функция. Это очень просто и быстро. Преимущество этого, о котором я не говорю, является идеальным, является эффективным решением для чисел в большом диапазоне, потому что вы только когда-либо проверяете числа, которые вы уже выбрали и сохранили, и не нуждаетесь в потенциально большом массиве для хранения значений вы отклонили его, чтобы он не вызывал проблем с памятью из-за размера массива.

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

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 

Answer 4

Он отлично работает:

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