【原创】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)))