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

2024-05-21 03:37| 来源: 网络整理| 查看: 265

在活动中，我们常会有抽奖，抽奖箱准备繁琐，现在多采用线上抽奖方式，下面用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

【本文地址】

公司简介

联系我们