使用VBA的唯一随机数

我正在尝试在用户定义的范围内创build一系列唯一的（非重复的）随机数字。 我设法创build了随机数字，但我得到重复的值。 我怎样才能确保随机数字永远不会重复？

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

 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 3

我看到你有一个被接受的答案，但无论什么值得在这里是我的刺这个问题。 这个使用布尔函数而不是数值数组。 这是非常简单而快速的。 它的好处，我不是说是完美的，是一个长期的数字有效的解决scheme，因为你只检查你已经select和保存的数字，并不需要一个潜在的大数组来保存值你已经拒绝了，所以不会因为数组的大小而导致内存问题。

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