Excel制作年会抽奖程序，VBA源码，就是这么简单

公司年会中，如果有一个抽奖环节，那就是需要有一个随机过程来进行抽奖活动。

本节将介绍一个小方法，通过一个VBA代码来实现整个抽取过程。

实现方法

既然是抽奖，那么就涉及到一个随机过程，也就是说不一定抽到谁，但要有一个抽取名单，也就是一个随机池。

我们把这个随机池设定为一个工作表单元格内容，或者是一个数组，本节示例中以数组来进行随机抽取。

过程界面如下图所示：

三个按钮，一个开始、一个停止和一个重置复位。

每个按钮有不同的过程。

随机过程中会对已经抽取出来的名字进行一个筛选处理，也就是说下次抽取就不会再把已经抽取的人再次抽取出来。

实现方法是将已经抽取的人放置到一个数组里，下次抽取通过遍历这个数组就可以确定是否已经抽取出来，如果存在就不进行抽取。

代码

全局变量定义

Option Explicit Dim xArr()'定名义单数组 Dim isID As Integer Dim isIDarr(), iid As Integer'定义筛选名单数组 Dim isTrue As Boolean'定义退出循环变量

开始按钮代码

Private Sub 开始抽取() On Error Resume Next Me.CommandButton1.Enabled = False isTrue = False Dim xCaption As String Dim xR As Range, r As Range, ir As Long ir = ThisWorkbook.Worksheets(2).Range("A65535").End(xlUp).Row If ir <= 1 Or ir > 65535 Then Exit Sub Set xR = ThisWorkbook.Worksheets(2).Range("A2:A" & ir) If xR.Count <> 1 Then xArr = Application.WorksheetFunction.Transpose(xR) Else ReDim xArr(0, 0) xArr(0, 0) = xR.Value End If Dim idTrue As Boolean Do'循环抽取 idTrue = False isID = VBA.Int((UBound(xArr, 1) - 1 + 1) * Rnd + 1) For iid = LBound(isIDarr) To UBound(isIDarr) If isIDarr(iid) = isID Then idTrue = True Exit For End If Next iid If Not idTrue Then xCaption = xArr(isID) Me.Shapes(1).TextFrame.Characters.Text = xCaption'显示名单 End If DoEvents Loop Until isTrue ir = ThisWorkbook.Worksheets(2).Range("C65535").End(xlUp).Row + 1 ThisWorkbook.Worksheets(2).Range("C" & ir).Value = xCaption Set xR = Nothing Set r = Nothing Erase xArr End Sub

停止按钮代码

Private Sub 停止() On Error Resume Next isTrue = True'退出循环 If UBound(xArr) = UBound(isIDarr) Then MsgBox "没有可选人了!", vbInformation, "提示" Exit Sub End If Me.CommandButton1.Enabled = True ReDim Preserve isIDarr(UBound(isIDarr) + 1) isIDarr(UBound(isIDarr)) = isID End Sub

重置按钮代码

Private Sub 重置() Dim ir As Integer Me.CommandButton1.Enabled = True ir = ThisWorkbook.Worksheets(2).Range("C65535").End(xlUp).Row + 1 ThisWorkbook.Worksheets(2).Range("C2:C" & ir).Value = "" Erase isIDarr ReDim isIDarr(0) End Sub