在活动中，我们常会有抽奖，抽奖箱准备繁琐，现在多采用线上抽奖方式，下面用Excel VBA写了一个简单的抽奖小程序
简单测试效果如下，可实现：
多次抽奖，且每次抽奖都不重复
抽奖界面滚动人员信息，点击抽奖按钮锁定中奖人员
中奖人员信息在右侧公示区域展示，最新中奖人员展示在最上方
设置了一部分误点、误操作提示，以及抽奖完成提示等
做了一个抽奖简单演示，演示GIF如下：
实现代码如下，按需自取，转载请备注出处：
'申明Flag、d、e三个模块变量，跨进程引用，实现滚动和抽奖数据传递 Dim Flag As Boolean '屏幕停止滚动并抽奖的判断参数 Dim d As Object '将随机抽取的中奖人员按自增键储存 Dim e As Object '将随机抽取的中奖人员按原键储存 Sub 重置() '清空上次抽奖内容，将人员名单复制到辅助列 Application.ScreenUpdating = False '屏幕刷新禁用，不展示清空数据过程 Sheets("抽奖界面").Select Sheets("抽奖界面").Range("E2") = 0 Sheets("抽奖界面").Range(Range("B6"), Range("F15")).ClearContents Sheets("抽奖界面").Range(Range("J3"), Range("M3").End(xlDown)).ClearContents Sheets("人员名单").Select Sheets("人员名单").Range(Range("E2"), Range("F2").End(xlDown)).ClearContents Sheets("人员名单").Range(Range("A2"), Range("B2").End(xlDown)).Copy Sheets("人员名单").Range("E2") Sheets("抽奖界面").Select Application.ScreenUpdating = True '屏幕刷新开启，为滚动抽奖做准备 End Sub Sub 准备() '准备开始抽奖，灰色区域滚动更新中奖人员 Set d = Nothing Set e = Nothing 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 Flag = True Set dict_id = CreateObject("scripting.dictionary") '变量、字典赋值 num_agent = Sheets("抽奖界面").Range("F2") For i = 1 To num_agent dict_id(i) = Sheets("人员名单").Cells(i + 1, 5) 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 抽奖() Dim m As Integer If Not Flag Then MsgBox ("请先点击准备按钮，再开始抽奖！！！") Exit Sub End If Flag = False '停止抽奖滚动，中奖人员确定 Set f = CreateObject("Scripting.Dictionary") Set dict_agent = 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("E:F"), 2, 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, 13)) Else f(i) = Sheets("抽奖界面").Range(Cells(i + 2 - num, 10), Cells(i + 2 - num, 13)) End If Next Sheets("抽奖界面").Range(Cells(3, 10), Cells(num_exist + num + 2, 13)).ClearContents For j = 1 To num_exist + num Sheets("抽奖界面").Range(Cells(2 + j, 10), Cells(2 + j, 13)) = f(j) Next '奖项抽取完成后提示人员变更参数 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 k = 1 To num_agent If Not e.Exists(k) Then dict_agent(k) = Sheets("人员名单").Range(Cells(k + 1, 5), Cells(k + 1, 6)) End If Next Sheets("人员名单").Range(Cells(2, 5), Cells(num_agent + 1, 6)).ClearContents m = 1 For Each Key In dict_agent Sheets("人员名单").Range(Cells(m + 1, 5), Cells(m + 1, 6)) = dict_agent(Key) m = m + 1 Next Sheets("抽奖界面").Select Application.ScreenUpdating = True '屏幕刷新开启，为下一轮滚动抽奖做准备 End Sub