生成有重复率的随机数序列
本帖最后由 tlwh163 于 2024-11-18 20:08 编辑=====================================================================
***** 这一段不要了 换用后面的代码 *****
想不出什么更好的办法 先丢出来 帮忙看看怎么搞
''生成一组随机数序列,可以指定重复率[ 参数: 待填充数组, 数据数量, 重复率% ]
Sub RanSequence(Result() As Long, ByVal ItemCount As Long, Optional ByVal Repetition As Byte = 0)
If ItemCount < 2 Or Repetition > 100 Then Exit Sub
ReDim Result(0 To ItemCount - 1): If UBound(Result) < 0 Then Exit Sub
Dim i As Long, k As Long
k = Fix(((100# - Repetition) / 100#) * ItemCount) '不重复的数量
For i = 0 To k - 1: Result(i) = i: Next '不重复的原始数据
For i = k To ItemCount - 1 '附加重复的原始数据(如果有重复率)
Result(i) = Fix(k * Rnd)
Next
Randomize '把数组打乱顺序
For i = ItemCount - 1 To 1 Step -1
k = Fix(i * Rnd)
Result(i) = Result(i) Xor Result(k)
Result(k) = Result(i) Xor Result(k)
Result(i) = Result(i) Xor Result(k)
Next
End Sub
=================================================================================================================
Private Sub Command1_Click()
Dim a As Long, b As Long: a = 2: b = 5000 '概率区间
Dim c As Long: c = (b - a) + 1 '区间长度 c = (b - a) + 1
Dim n As Long: n = 100 '数据总量 n = 100
Dim p As Long: p = 20 '重复率 p = 20 (%)
Dim w As Long: w = Fix((100# - p) / 100# * n) '不重复的数量
If c < w Then MsgBox "概率区间不够" : Exit Sub
Dim x() As Long, y() As Long
ReDim x(0 To c - 1): If UBound(x) = -1 Then MsgBox "内存不足": Exit Sub
ReDim y(0 To n - 1): If UBound(y) = -1 Then MsgBox "内存不足": Exit Sub
''------生成一组随机数序列,可以指定重复率----------
Dim i As Long, k As Long: Randomize
For i = 0 To c - 1: x(i) = a + i: Next '填充概率区间
For i = c - 1 To 1 Step -1
k = Fix(Rnd * i) '概率区间打乱顺序
x(i) = x(i) Xor x(k): x(k) = x(i) Xor x(k): x(i) = x(i) Xor x(k)
Next
For i = 0 To w - 1: y(i) = x(i): Next '填充不重复的部分
For i = w To n - 1
k = Fix(Rnd * w): y(i) = y(k) '从不重复的部分随机取数,造成重复
Next
For i = n - 1 To 1 Step -1
k = Fix(Rnd * i) '再1次打乱顺序
y(i) = y(i) Xor y(k): y(k) = y(i) Xor y(k): y(i) = y(i) Xor y(k)
Next
''-------验证重复率--------------------------------
w = 0
For i = 0 To n - 1
If y(i) <> (a - 1) Then
w = w + 1
For k = i + 1 To n - 1
If y(k) = y(i) Then y(k) = (a - 1)
Next
End If
Next
Debug.Print "不重复的数有 " & Str(w) & " 个",
Debug.Print "重复率 = " & Str(Fix(CDbl(n - w) / n * 100#)) & "%"
End Sub
重复率的定义是什么 去掉所有出现的数值1次剩下的就是重复项
重复率 = 重复项 / 总数量
比如:0 1 2 3 4 5 (2) 6 7 (3) -> 重复率 20% 如果重复率不是精确值可以这样，如果重复率必须准确没啥简单办法
Option Explicit
Private Sub Command1_Click()
Dim a, b, c, n '概率区间a b ,差值c,总量n
Dim p, p0, prnd '重复概率p 取样p0,随机数本身非重复率prnd
Dim i
Dim d()
a = 2
b = 5000
n = 100
p = 6
prnd = 0.92
c = b - a
ReDim d(n)
Randomize
For i = 0 To n - 1
p0 = Rnd() * 100 - prnd * p
If p0 > 0 Then
d(i) = a + Fix(c * Rnd())
Else
d(i) = d(Fix(i * Rnd()))
End If
Debug.Print d(i)
Next
End Sub
不知道能不能看到图片
似乎重复率不是很稳定啊 增加稳定性可以通过统计 p0 < 0 的次数更加精准些当次数 大于 n * prnd *p / 100 就不在插入重复值，不过这样样本的重复数就不均匀了
页:
[1]