【原创】ExcelVBA实现不重复、多次抽奖⼩程序在活动中，我们常会有抽奖，抽奖箱准备繁琐，现在多采⽤线上抽奖⽅式，下⾯⽤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)).ClearContentsresize函数vba
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))）

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。