抽取 30 个在 1-1000 之间不重复的随机数

Question

我想在 Excel 中抽奖，在 1-1000 之间抽取大约 30 个随机数字，并且这 30 个数字不重复。

如何检查数组是否有重复项，如果有则再次运行代码。

下面的 VBA 代码生成随机数/中奖者。

Public Sub CommandButton1_Click()
    Dim MIN, MAX, OUT, i
    Static a, n, z
    MIN = Array(1, 1, 1, 1): MAX = Array(10, 10, 10, 10): OUT = Array("Q1", "Q2", "Q3", "Q4")
    z = UBound(MIN)
    If Not IsArray(n) Then ReDim a(z): ReDim n(z)
    For i = 0 To z
        If n(i) = 0 Then Reset a(i), n(i), MIN(i), MAX(i)
        Range(OUT(i)) = a(i)(n(i)): n(i) = n(i) - 1
    Next
End Sub

Private Sub Reset(a, n, MIN, MAX)
    Dim i, j
    Randomize: n = MAX - MIN + 1: ReDim a(1 To n)
    For i = 1 To n
        j = Rnd * (i - 1) + 1: a(i) = a(j): a(j) = i - 1 + MIN
    Next
End Sub

Answer 1

如果您有 Excel 365，您可以使用 VBA、

Evaluate

和公式：

Sub writeRandomNumbers(rgTarget As Range)
rgTarget.Resize(30).Value = Evaluate("=TAKE(SORTBY(SEQUENCE(1000),RANDARRAY(1000)),30)")
End Sub

你可以这样称呼这个子：

Public Sub CommandButton1_Click()
writeRandomNumbers Range(1, 1)
End Sub

但显然您也可以在表格上使用公式本身。 但每当计算另一个公式时它就会更新。

每当用户单击按钮时，都会使用 VBA 代码将随机 values 写入工作表。

Answer 2

我喜欢艾克提供的公式的想法（并投票了，它对我有用）。
以下解决方案也适用于旧版本的 Excel。它使用

Collection

来保存所有彩票的列表。在示例中，它将填充 1 到 1000 之间的数字，但您可以填充任何您想要的值。基本思想是在该集合中创建一个随机索引，写入集合成员的值并从集合中删除该条目。

Sub writeRandomNumbers(tickets As Collection, rgTarget As Range, drawCount As Long)
    Dim i As Long
    For i = 1 To drawCount
        Dim ticketIndex As Long
        ticketIndex = Int(Rnd * tickets.Count) + 1
        rgTarget.Offset(i - 1, 0) = tickets(ticketIndex)
        tickets.Remove ticketIndex              ' Remove this ticket
        If tickets.Count = 0 Then Exit Sub      ' No more tickets
    Next
End Sub

为了进行测试，可以用这个小例程填充集合：

Function createTickets() As Collection
    ' This is only an example, creating tickets from 1 to 1000
    ' You can fill the collection which whatever you want (eg Names from a Range).
    Set createTickets = New Collection
    Dim i As Long
    For i = 1 To 1000
        createTickets.Add i, CStr(i)
    Next
End Function

这是我的测试程序：

Sub test()
    Dim tickets As Collection
    Set tickets = createTickets
    writeRandomNumbers tickets, ThisWorkbook.Sheets(1).Range("A1"), 30
End Sub

Answer 3

为什么不直接设置 40 行左右

=RANDBETWEEN(1,1000)

然后使用 =unique(rangehere) 消除任何重复项，并获取前 30 个项目

Answer 4

我认为关键是避免DUPLICATES并生成独特的序列。尝试遵循你的结构，

`// removed randomisation, added generator
`//
Public Sub CommandButton1_Click()
    Const numRng As Integer = 4
    Static a(1 To numRng) As Collection
    Static n(1 To numRng) As Integer
    Dim MIN As Variant, MAX As Variant, OUT As Variant
    Dim i As Integer

    MIN = Array(1, 1, 1, 1)
    MAX = Array(10, 10, 10, 10)
    OUT = Array("Q1", "Q2", "Q3", "Q4")
    
    For i = 1 To numRng
        If n(i) = 0 Then
            Set a(i) = New Collection
            GenSeq a(i), MIN(i - 1), MAX(i - 1)
            n(i) = a(i).Count
        End If
        Range(OUT(i - 1)).Value = a(i)(n(i))
        n(i) = n(i) - 1
    Next i
End Sub

Private Sub GenSeq(ByRef sequence As Collection, ByVal MIN As Integer, ByVal MAX As Integer)
    Dim numPool As Object
    Dim num As Variant
    Set numPool = CreateObject("Scripting.Dictionary")
    
    For num = MINValue To MAXValue
        numPool(num) = True
    Next num
    
    While numPool.Count > 0
        num = numPool.Keys()(Int((numPool.Count) * Rnd))
        sequence.Add num
        numPool.Remove num
    Wend
End Sub