Excel VBA活动抽奖小程序

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