=====================================================================

***** 这一段不要了 换用后面的代码 *****


想不出什么更好的办法 先丢出来 帮忙看看怎么搞


''生成一组随机数序列,可以指定重复率  [ 参数: 待填充数组, 数据数量, 重复率% ]
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     '概率区间 [a, b]
    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%

如果重复率不是精确值可以这样，如果重复率必须准确没啥简单办法

1. Option Explicit
   
2. 
   
3. Private Sub Command1_Click()
   
4. Dim a, b, c, n '概率区间a b ,差值c,总量n
   
5. Dim p, p0, prnd '重复概率p 取样p0,随机数本身非重复率prnd
   
6. Dim i
   
7. Dim d()
   
8. a = 2
   
9. b = 5000
   
10. n = 100
    
11. p = 6
    
12. prnd = 0.92
    
13. c = b - a
    
14. ReDim d(n)
    
15. Randomize
    
16. For i = 0 To n - 1
    
17.    p0 = Rnd() * 100 - prnd * p
    
18.    If p0 > 0 Then
    
19.        d(i) = a + Fix(c * Rnd())
    
20.    Else
    
21.        d(i) = d(Fix(i * Rnd()))
    
22.    End If
    
23.    Debug.Print d(i)
    
24. 
    
25. Next
    
26. 
    
27. 
    
28. End Sub
    

复制代码

不知道能不能看到图片

似乎重复率不是很稳定啊

增加稳定性可以通过统计 p0 < 0 的次数更加精准些当次数 大于 n * prnd *  p / 100 就不在插入重复值，不过这样样本的重复数就不均匀了