公司年会中，如果有一个抽奖环节，那就是需要有一个随机过程来进行抽奖活动。
本节将介绍一个小方法，通过一个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
工作表
工作表就简单了，三个字段，第一列为所有抽取人姓名，第二列设置奖项，第三列是自动添加抽取出来的名单。
这样就完成了一个抽奖过程程序制作，应用起来很简单。
欢迎关注、收藏
---END---