Excel VBA实现1-1000范围内30个无重复随机数抽奖方案问询

一、适配需求的VBA代码 #

原代码针对4组1-10的随机数抽取场景，下面修改为生成1-1000范围内的30个不重复随机数，直接输出到工作表的A1:A30区域（可自行调整输出位置）：

Public Sub DrawLottery()
    Const MIN_NUM As Integer = 1
    Const MAX_NUM As Integer = 1000
    Const DRAW_COUNT As Integer = 30
    Dim resultArr() As Integer
    Dim outputRange As Range
    
    ' 生成无重复随机数数组
    GenerateUniqueRandoms resultArr, MIN_NUM, MAX_NUM, DRAW_COUNT
    
    ' 指定输出区域，可修改为Range("C1:C30")等目标位置
    Set outputRange = ThisWorkbook.ActiveSheet.Range("A1:A" & DRAW_COUNT)
    outputRange.Value = Application.Transpose(resultArr)
End Sub

Private Sub GenerateUniqueRandoms(ByRef outArr() As Integer, minVal As Integer, maxVal As Integer, drawCount As Integer)
    Dim totalNums As Integer
    Dim tempArr() As Integer
    Dim i As Integer, j As Integer, temp As Integer
    
    totalNums = maxVal - minVal + 1
    If drawCount > totalNums Then
        MsgBox "抽取数量不能超过数值范围的总数！"
        Exit Sub
    End If
    
    ' 初始化包含所有数值的数组
    ReDim tempArr(1 To totalNums)
    For i = 1 To totalNums
        tempArr(i) = minVal + i - 1
    Next i
    
    ' Fisher-Yates洗牌算法：打乱数组顺序，天然无重复
    Randomize
    For i = totalNums To totalNums - drawCount + 1 Step -1
        j = Int(Rnd * i) + 1
        ' 交换位置实现随机抽取
        temp = tempArr(i)
        tempArr(i) = tempArr(j)
        tempArr(j) = temp
    Next i
    
    ' 提取指定数量的结果
    ReDim outArr(1 To drawCount)
    For i = 1 To drawCount
        outArr(i) = tempArr(totalNums - drawCount + i)
    Next i
End Sub

二、重复检查的实现方法 #

原代码的Reset过程采用Fisher-Yates洗牌算法，这种方式直接从完整数值池中随机交换位置，生成的数组天然无重复，无需事后检查，是效率最高的无重复随机数生成方式。

如果需要针对其他生成逻辑手动检查重复，可使用以下两种方法：

方法1：字典快速查重（适合大数据量）

Function HasDuplicates(arr() As Integer) As Boolean
    Dim dict As Object
    Dim i As Integer
    
    Set dict = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    For i = LBound(arr) To UBound(arr)
        dict.Add arr(i), ""
        ' 若添加失败，说明已存在重复值
        If Err.Number <> 0 Then
            HasDuplicates = True
            Exit Function
        End If
    Next i
    HasDuplicates = False
End Function

使用示例：If HasDuplicates(resultArr) Then DrawLottery（检测到重复则重新运行生成逻辑）

方法2：数组遍历查重（适合小数据量）

Function HasDuplicatesByLoop(arr() As Integer) As Boolean
    Dim i As Integer, j As Integer
    
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) = arr(j) Then
                HasDuplicatesByLoop = True
                Exit Function
            End If
        Next j
    Next i
    HasDuplicatesByLoop = False
End Function

三、代码使用步骤 #

1. 打开Excel，按Alt+F11打开VBA编辑器
2. 右键点击目标工作簿 → 插入 → 模块
3. 将上述代码粘贴到模块中
4. 返回工作表，按Alt+F8选择DrawLottery宏运行即可生成结果

内容的提问来源于stack exchange，提问作者Oskar Prenk