Excel VBA无需重复即可获得随机整数值

Question

用VBA编写一个子程序，生成一张由1到40随机抽取的6个整数组成的中奖彩票。

为了有一个小的模拟动画，range("A1:E8") 应该包含数字 1 到 40，然后子程序应该使用彩色单元格在这些数字之间循环，然后在选定的获胜时暂停 2 秒数字。然后应在范围（“G2：G7”）中打印中奖号码列表。如果抽出的号码之前已在列表中抽出，则应重新绘制一个新号码。

我只能做到以下几点。

Option Explicit
Sub test1()
  Sheet1.Cells.Clear
  Dim i As Integer
  For i = 1 To 40
      Cells(i, 1) = i
  Next
End Sub

'-----------------------------
Option Explicit
Option Base 1

Function arraydemo(r As Range)
  Dim cell As Range, i As Integer, x(40, 1) As Double
  i = 1
  For Each cell In r
      x(i, 1) = cell.Value
      i = i + 1
  Next cell
  arraydemo = x
End Function
Sub test3()
  Dim x() As String
  chose = Int(Rnd * UBound(x))
End Sub

我在其他地方卡住了，子 test3()，在这里似乎不合适。我需要一些建议。另外，我为我糟糕的格式道歉，我是新手。

Answer 1

像这样填充你的范围：

range("A1:E8") 应该包含数字 1 到 40

Sheet1.Cells.Clear

Dim i As Integer
Dim rng as Range
Set rng = Range("A1:E8")
For i = 1 To 40
    rng
Next    

生成一张由 6 个整数组成的中奖彩票，从 1 到 40 随机抽取

使用字典对象来跟踪在While 循环中选择了哪些项目（并防止重复）（直到选择了 6 个数字）：

Dim picked as Object
Set picked = CreateObject("Scripting.Dictionary")
'Select six random numbers:
i = 1
While picked.Count < 6
    num = Application.WorksheetFunction.RandBetween(1, 40)
    If Not picked.Exists(num) Then
        picked.Add num, i
        i = i + 1
    End If
Wend

使用Application.Wait方法做“暂停”，你可以这样设置一个过程：

'Now, show those numbers on the sheet, highlighting each cell for 2 seconds
For Each val In picked.Keys()
    rng.Cells(picked(val)).Interior.ColorIndex = 39 'Modify as needed
    Application.Wait Now + TimeValue("00:00:02")
    rng.Cells(picked(val)).Interior.ColorIndex = xlNone
Next

然后应该在范围（“G2：G7”）中打印中奖号码列表。

打印picked 字典中的键：

Range("G2:G7").Value = Application.Transpose(picked.Keys())

把它们放在一起：

Sub Lotto()
    Dim i As Integer, num As Integer
    Dim rng As Range
    Dim picked As Object 'Scripting.Dictionary
    Dim val As Variant


    'Populate the sheet with values 1:40 in range A1:E8
    Set rng = Range("A1:E8")
    For i = 1 To 40
        rng.Cells(i) = i
    Next

    'Store which numbers have been already chosen
    Set picked = CreateObject("Scripting.Dictionary")

    'Select six random numbers:
    i = 1
    While picked.Count < 6
        num = Application.WorksheetFunction.RandBetween(1, 40)
        If Not picked.Exists(num) Then
            picked.Add num, i
            i = i + 1
        End If
    Wend

    'Now, show those numbers on the sheet, highlighting each cell for 2 seconds
    For Each val In picked.Keys()
        rng.Cells(val).Interior.ColorIndex = 39 'Modify as needed
        Application.Wait Now + TimeValue("00:00:02")
        rng.Cells(val).Interior.ColorIndex = xlNone
    Next

    'Display the winning series of numbers in G2:G7
    Range("G2:G7").Value = Application.Transpose(picked.Keys())
End Sub

注意这绝对不适用于 Excel for Mac，您需要使用 Collection 而不是 Dictionary，因为 Scripting.Runtime 库在 Mac OS 上不可用。

Answer 2

除了成员 David Zemens 给出的出色回答之外，以下是用“纯”Excel VBA 编写的通用函数，它不包含任何 Excel 工作表函数，也不包含字典对象（回复：CreateObject("Scripting.Dictionary"）。

Option Explicit

'get N random integer numbers in the range from LB to UB, NO repetition
'general formula: Int ((UpperBound - LowerBound + 1) * Rnd + LowerBound)
Function RandomNumbers(LB As Integer, UB As Integer, N As Integer) As Variant
    Dim I As Integer
    Dim arrRandom() As Integer
    Dim colRandom As New Collection
    Dim colItem As Variant
    Dim tempInt As Integer
    Dim tempExists As Boolean

    'check that ArraySize is less that the range of the integers
    If (UB - LB + 1 >= N) Then

        While colRandom.Count < N

            Randomize
            ' get random number in interval
            tempInt = Int((UB - LB + 1) * Rnd + LB)

            'check if number exists in collection
            tempExists = False
            For Each colItem In colRandom
                If (tempInt = colItem) Then
                    tempExists = True
                    Exit For
                End If
            Next colItem

            ' add to collection if not exists
            If Not tempExists Then
                colRandom.Add tempInt
            End If
        Wend

        'convert collection to array
        ReDim arrRandom(N - 1)
        For I = 0 To N - 1
            arrRandom(I) = colRandom(I + 1)
        Next I

        'return array of random numbers
        RandomNumbers = arrRandom
    Else
        RandomNumbers = Nothing
    End If
End Function

'get 5 Random numbers in the ranger 1...10 and populate Worksheet
Sub GetRandomArray()
    Dim arr() As Integer

    'get array of 5 Random numbers in the ranger 1...10
    arr = RandomNumbers(1, 10, 5)

    'populate Worksheet Range with 5 random numbers from array
    If (IsArray(arr)) Then
        Range("A1:A5").Value = Application.Transpose(arr)
    End If
End Sub

功能

Function RandomNumbers(LB As Integer, UB As Integer, N As Integer) 

返回 LB...UB 范围内的 N 个随机数组成的数组，不重复。

示例Sub GetRandomArray() 演示了如何在 1...10 范围内获取 5 个随机数并填充工作表范围：它可以针对任何特定要求进行定制（例如 PO 要求中的 1...40 中的 8 个）。

---

附录 A（由 David Ziemens 提供）

或者，您可以完全不依赖 Collection 对象来做类似的事情。构建一个分隔字符串，然后使用Split 函数将字符串转换为一个数组，并将其返回给调用过程。

这实际上将数字返回为String，但这对于这个特定的用例来说无关紧要，如果确实如此，则可以轻松修改。

Option Explicit
Sub foo()
Dim arr As Variant

arr = RandomNumbersNoCollection(1, 40, 6)

End Sub


'get N random integer numbers in the range from LB to UB, NO repetition
'general formula: Int ((UpperBound - LowerBound + 1) * Rnd + LowerBound)
Function RandomNumbersNoCollection(LB As Integer, UB As Integer, N As Integer)
    Dim I As Integer
    Dim numbers As String ' delimited string
    Dim tempInt As Integer
    Const dlmt As String = "|"

    'check that ArraySize is less that the range of the integers
    If (UB - LB + 1 >= N) Then

            ' get random number in interval
        Do
            Randomize
            tempInt = Int((UB - LB + 1) * Rnd + LB)
            If Len(numbers) = 0 Then
                numbers = tempInt & dlmt
            ElseIf InStr(1, numbers, tempInt & dlmt) = 0 Then
                numbers = numbers & tempInt & dlmt
            End If

        Loop Until UBound(Split(numbers, dlmt)) = 6
        numbers = Left(numbers, Len(numbers) - 1)
    End If
    RandomNumbersNoCollection = Split(numbers, dlmt)

End Function