使用 VBA 的唯一随机数
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/18543169/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Unique Random Numbers using VBA
提问by Carlos
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
回答by chris neilsen
Here's a method of guaranteeing unique integerrandom 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
注意：请参阅这篇关于 shuffle 偏差的维基百科文章
The edit fixed one source of bias. The inherent limitations of Rnd(based on a 32 bit seed) and Modulo bias remain.
编辑修复了一个偏见来源。Rnd（基于 32 位种子）和模偏差的固有限制仍然存在。
回答by u3397819
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
回答by Samir Lakhani
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
回答by Moreno
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
