【原创】Excel VBA实现不重复、多次抽奖小程序

在活动中，我们常会有抽奖，抽奖箱准备繁琐，现在多采用线上抽奖方式，下面用Excel VBA写了一个简单的抽奖小程序

简单测试效果如下，可实现：

• 多次抽奖，且每次抽奖都不重复

• 抽奖界面滚动人员信息，点击抽奖按钮锁定中奖人员

• 中奖人员信息在右侧公示区域展示，最新中奖人员展示在最上方

• 设置了一部分误点、误操作提示，以及抽奖完成提示等

• 已优化，支持万人级抽奖

做了一个抽奖简单演示，演示GIF如下：

实现代码如下，按需自取，转载请备注出处：

\'申明Flag、d、e三个模块变量，跨进程引用，实现滚动和抽奖数据传递
Dim Flag As Boolean     \'屏幕停止滚动并抽奖的判断参数
Dim d As Object         \'将随机抽取的中奖人员按自增键储存
Dim e As Object         \'将随机抽取的中奖人员按原键储存
Dim dict_id As Object   \'本轮参与抽奖人员工号


Sub 重置()

\'清空上次抽奖内容，将人员名单复制到辅助列
Application.ScreenUpdating = False  \'屏幕刷新禁用，不展示清空数据过程

Sheets("抽奖界面").Select
Sheets("抽奖界面").Range("E2") = 0
Sheets("抽奖界面").Range(Range("B6"), Range("F15")).ClearContents
Sheets("抽奖界面").Range(Range("J3"), Range("P3").End(xlDown)).ClearContents
Sheets("人员名单").Select
Sheets("人员名单").Range(Range("H3"), Range("H3").End(xlDown)).ClearContents
Sheets("人员名单").Range(Range("A3"), Range("A3").End(xlDown)).Copy _
Sheets("人员名单").Range("H3")
Sheets("抽奖界面").Select

Application.ScreenUpdating = True   \'屏幕刷新开启，为滚动抽奖做准备

End Sub


Sub 准备()  \'准备开始抽奖，灰色区域滚动更新中奖人员

Set d = Nothing
Set e = Nothing
Set dict_id = Nothing
Flag = True

text_level = Sheets("抽奖界面").Range("A2")       \'抽取奖项
lottery_target = Sheets("抽奖界面").Range("D2")   \'抽奖次数目标

\'判断该奖项是否已经抽取过，当变更了抽取奖项时，自动重置已抽取次数为0
If Application.WorksheetFunction.CountIfs(Sheets("抽奖界面").Range("J:J"), _
text_level) = 0 Then    
    Sheets("抽奖界面").Range("E2") = 0    
End If

\'判断剩余参与人数是否足够抽奖
If Sheets("抽奖界面").Range("F2") < Sheets("抽奖界面").Range("C2") Then
    MsgBox ("剩余参与人数不足，请修改抽奖参数或停止抽奖！！！")    
    Exit Sub    
End If

\'判断该奖项是否已抽取完，提示操作人员是选择加抽还是变更抽奖奖项
If Sheets("抽奖界面").Range("E2") >= lottery_target Then
    QS_Return = MsgBox(text_level & "抽奖" & lottery_act & "已完成！" & _
Chr(10) & "要变更奖项请选择是" & Chr(10) & "要再次抽取" & text_level & _
"请选择否", vbYesNo + vbQuestion, "提示")
    If QS_Return = vbYes Then    
        MsgBox (text_level & "请重新选择奖项，输入抽奖次数和单次抽奖人数！")    
        Exit Sub        
    Else    
        Sheets("抽奖界面").Range("D2") = Sheets("抽奖界面").Range("D2") + _
Sheets("抽奖界面").Range("E2")        
    End If    
End If

\'清空抽奖滚动区域
Sheets("抽奖界面").Range(Range("B6"), Range("F15")).ClearContents
num_agent = Sheets("抽奖界面").Range("F2")

\'字典赋值
Set dict_id = CreateObject("Scripting.Dictionary")
For i = 1 To num_agent
    dict_id(i) = Sheets("人员名单").Cells(i + 2, 8)    
Next
num = Sheets("抽奖界面").Range("C2")

\'持续滚动抽奖界面，等待点击抽奖后停止
Do
    Set d = CreateObject("Scripting.Dictionary")
    Set e = CreateObject("Scripting.Dictionary")
    For j = 1 To num    
        Do        
            a = Int(Rnd * num_agent) + 1        
        Loop Until Not e.Exists(a)                
        d(j) = dict_id(a)                
        e(a) = dict_id(a)    
    Next    
    For m = 1 To 10        
        For n = 1 To 5            
            If n + (m - 1) * 5 > num Then            
                Exit For                
            Else            
                Sheets("抽奖界面").Cells(m + 5, n + 1) = d(n + (m - 1) * 5)                    
                DoEvents    \'将控制权传给操作系统，实现滚动的同时可以点击抽奖按钮，非常关键！！！                     
            End If            
        Next            
    Next    
Loop Until Flag = False

End Sub


Sub 抽奖()

If Not Flag Then
    MsgBox ("请先点击准备按钮，再开始抽奖！！！")    
    Exit Sub    
End If

Flag = False    \'停止抽奖滚动，中奖人员确定
Set f = CreateObject("Scripting.Dictionary")
text_level = Sheets("抽奖界面").Range("A2")
Sheets("抽奖界面").Range("E2") = Sheets("抽奖界面").Range("E2") + 1     \'已抽取次数+1
lottery_act = Sheets("抽奖界面").Range("E2") \'已抽取次数，后面需要判断是否提示抽奖完成
num = Application.WorksheetFunction.CountA(Sheets("抽奖界面").Range("B6:F15"))
num_exist = Sheets("抽奖界面").Range("G2")

\'将新中奖人员信息添加至公示区域末尾
For i = 1 To num
    Sheets("抽奖界面").Cells(2 + num_exist + i, 10) = text_level   
    Sheets("抽奖界面").Cells(2 + num_exist + i, 11) = lottery_act   
    Sheets("抽奖界面").Cells(2 + num_exist + i, 12) = d(i)    
    Sheets("抽奖界面").Cells(2 + num_exist + i, 13) = _
Application.WorksheetFunction.VLookup(d(i), Sheets("人员名单").Range("A:E"), 2, False)    
    Sheets("抽奖界面").Cells(2 + num_exist + i, 14) = _
Application.WorksheetFunction.VLookup(d(i), Sheets("人员名单").Range("A:E"), 3, False)    
    Sheets("抽奖界面").Cells(2 + num_exist + i, 15) = _
Application.WorksheetFunction.VLookup(d(i), Sheets("人员名单").Range("A:E"), 4, False)    
    Sheets("抽奖界面").Cells(2 + num_exist + i, 16) = _
Application.WorksheetFunction.VLookup(d(i), Sheets("人员名单").Range("A:E"), 5, False)
Next

\'将所有中奖人员存放至字典
For i = 1 To num_exist + num
    If i <= num Then
        f(i) = Sheets("抽奖界面").Range(Cells(num_exist + i + 2, 10), _
Cells(num_exist + i + 2, 16))        
    Else        
        f(i) = Sheets("抽奖界面").Range(Cells(i + 2 - num, 10), Cells(i + 2 - num, 16))        
    End If
Next

Sheets("抽奖界面").Range(Cells(3, 10), Cells(num_exist + num + 3, 16)).ClearContents
Sheets("抽奖界面").[J3].Resize(f.Count, 7).Value = _
Application.Transpose(Application.Transpose(f.items))

\'奖项抽取完成后提示人员变更参数
If lottery_act = Sheets("抽奖界面").Range("D2") Then    
    MsgBox (text_level & "抽取" & lottery_act & "次已完成，请变更抽奖奖项和次数")    
End If

\'更新待抽奖人员名单，实现不重复抽奖
num_agent = Sheets("抽奖界面").Range("F2")
Application.ScreenUpdating = False  \'屏幕刷新禁用，不展示清空数据过程
Sheets("人员名单").Select

For Each Key In e
    dict_id.Remove (Key)
Next

Sheets("人员名单").Range(Range("H3"), Range("H3").End(xlDown)).ClearContents
Sheets("人员名单").[H3].Resize(dict_id.Count, 1).Value = _
Application.Transpose(dict_id.items)
Sheets("抽奖界面").Select

Application.ScreenUpdating = True   \'屏幕刷新开启，为下一轮滚动抽奖做准备

End Sub

功能实现思路：

• 通过随机函数Rnd产生[0,1)的随机数，再乘以当前参与人数放大，实现随机抽奖

• 通过字典的Exists方法判断是否重复，实现去重抽奖

• 定义模块变量，实现人员滚动和抽奖的分离

• DoEvents语句将控制权传给操作系统，实现滚动的同时可以点击抽奖按钮，是实现抽奖屏幕滚动更新的关键

• 最初以遍历的方式回填数据，发现参与人数上万时明显卡顿，改用字典的items方法回填数据（一维数据回填到列：Application.Transpose(dict.items)，二维数据回填到列：Application.Transpose(Application.Transpose(dict.items))）