EXCEL 抽奖 如何 多次抽奖不重复

用vba编个程序可以实现。

将一个案例分享给大家。程序页面如下：镇衡斗

部分代码如下：

Private Sub CommandButton4_Click()

'开始抽奖

Dim zb As String, dj As String, rs As Integer

Dim SARR(1 To 5000, 1 To 2) '存放本次抽奖的候选人清单 1-姓名 2-电话号码

'Dim lsARR '存放最近100次的候选人

Dim ZZ1 As Integer, ZZ2 As Integer, ZZ3 As Integer

'Dim jgarr

Dim ysARR(1 To 3, 1 To 3) As Integer '三种颜色参数

Dim zjZD '仅存放姓名+半角分号（)+4位尾号御磨

Dim myName As String

Dim hxRs As Integer, ZJRS As Integer '候选人数,中奖人数

Const lsRs = 100 '存放100位候选人

Set zjZD = CreateObject("scripting.dictionary")

'ReDim jgarr(1 To ZJRS) As Long

A = 0 '

ysARR(1, 1) = 255: ysARR(1, 2) = 250: ysARR(1, 3) = 0

ysARR(2, 1) = 255: ysARR(2, 2) = 10: ysARR(3, 3) = 10

ysARR(3, 1) = 255: ysARR(3, 2) = 250: ysARR(3, 3) = 0

'清空颜色

For I = 1 To 15

myName = "TextBox" &I

Set xx = Me.Controls(myName)

xx.BackColor = RGB(255, 255, 255)

xx.ForeColor = RGB(255, 215, 0)

xx.Font.Size = 10

xx.BackStyle = 0

ZZ3 = ZZ3 - 1

If ZZ3 = 0 Then ZZ3 = 15

Next I

zb = ComboBox1.Value

dj = ComboBox2.Value

ZJRS = ComboBox3.Value '中奖人数

'读取还可抽取人数

With Sheets("中奖人数设定")

For I = 3 To 8

If .Cells(I, 2) = zb Then Exit For

Next I

For j = 9 To 11

If .Cells(2, j) = dj Then Exit For

Next j

kcqrs = .Cells(I, j) '可抽取人数

End With

If ZJRS = 0 Or ZJRS >kcqrs Or ZJRS >15 Then

MsgBox ("抽奖人数设置不正确！")

Exit Sub

End If

ReDim jgarr(1 To ZJRS, 1 To 2)

'读取候选人 放入sarr

Select Case zb

Case "A"

lh = 2

Case "B"

lh = 5

Case "C"

lh = 8

Case "D"

lh = 11

Case "E"

lh = 14

Case "F"

lh = 17

End Select

hxRs = 0

With Sheets("人员清单")

HH = 3

Do While .Cells(HH, lh) <>""

If .Cells(HH, lh + 2) = "" Then '检查是否中奖，已经中奖的不得参与摇奖

hxRs = hxRs + 1

SARR(hxRs, 1) = .Cells(HH, lh)

SARR(hxRs, 2) = .Cells(HH, lh + 1)

End If

HH = HH + 1

Loop

End With

ZZ1 = 0: ZZ2 = 0: ZZ3 = 0

upperbound = hxRs

lowerbound = 1

'1-11:中奖人数和候选人数一样时，单独做一个循环

If ZJRS <hxRs Then GoTo 200

'一样时

Do While True

For ZZ2 = 1 To hxRs

myName = "TextBox" &ZZ2

Set xx = Me.Controls(myName)

xx.Text = SARR(ZZ2, 1) &Chr(10) &Right(SARR(ZZ2, 2), 4)

Next ZZ2

DoEvents '释放程序拦镇控制权，允许其他事件

Sleep (5) '延时ms

DoEvents '释放程序控制权，允许其他事件

If A = 1 Then GoTo 300

Loop

200:

Do While True

100:

SJS = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)

MYKEY = Trim(SARR(SJS, 1)) &"" &Trim(Right(SARR(SJS, 2), 4))

If zjZD.EXISTS(MYKEY) Then

ZZ1 = ZZ1 + 1

If ZZ1 >10000 Then

MsgBox ("数据异常！！！")

Exit Sub

End If

GoTo 100

End If

'ZZ1 = ZZ1 + 1

'If ZZ1 = 101 Then ZZ1 = 1

ZZ2 = ZZ2 + 1

If ZZ2 = ZJRS + 1 Then ZZ2 = 1

'ZZ3 = ZZ3 + 1

'If ZZ3 = 4 Then ZZ3 = 1

'lsARR(ZZ1) = sjs

myName = "TextBox" &ZZ2

Set xx = Me.Controls(myName)

'xx.Text = Left(SARR(SJS, 2), 3) &"XXXX" &Right(SARR(SJS, 2), 4)

xx.Text = SARR(SJS, 1) &Chr(10) &Right(SARR(SJS, 2), 4)

zjZD.RemoveAll

For I = 1 To ZJRS

myName = "TextBox" &I

Set xx = Me.Controls(myName)

If xx.Text <>"" Then

MYKEY2 = qczf(Left(xx.Text, InStr(xx.Text, Chr(10)) - 1)) &"" &Right(xx.Text, 4)

zjZD.Add MYKEY2, I

End If

Next I

'xx.BackColor = RGB(ysARR(ZZ3, 1), ysARR(ZZ3, 2), ysARR(ZZ3, 3))

DoEvents '释放程序控制权，允许其他事件

Sleep (5) '延时ms

DoEvents '释放程序控制权，允许其他事件

300:

If A = 1 Then

For I = 1 To ZJRS

myName = "TextBox" &I

Set xx = Me.Controls(myName)

xx.BackColor = RGB(ysARR(1, 1), ysARR(1, 2), ysARR(1, 3))

xx.ForeColor = RGB(0, 0, 255)

xx.Font.Size = 20

xx.BackStyle = 1

'ZZ3 = ZZ3 - 1

'If ZZ3 = 0 Then ZZ3 = 15

Next I

Exit Sub

End If

Loop

End Sub

Private Sub CommandButton5_Click()

A = 1

End Sub

Private Sub CommandButton6_Click() '记录中奖信息

Dim zjZD

Dim ZJRS

Dim zjArr

zb = ComboBox1.Value '组别

dj = ComboBox2.Value '等级

ZJRS = ComboBox3.Value '中奖人数

Set zjZD = CreateObject("scripting.dictionary")

'遍历文本框，获取中奖的电话号码

For I = 1 To ZJRS

myName = "TextBox" &I

Set xx = Me.Controls(myName)

ARR = Split(xx.Text, Chr(10))

MYTEXT = qczf(ARR(0)) &"" &qczf(ARR(1))

zjZD.Add MYTEXT, I

xx.Text = ""

xx.BackColor = RGB(255, 255, 255)

Next I

Select Case zb

Case "A"

lh = 2

Case "B"

lh = 5

Case "C"

lh = 8

Case "D"

lh = 11

Case "E"

lh = 14

Case "F"

lh = 17

End Select

With Sheets("人员清单")

For I = 3 To .Cells(10000, lh).End(xlUp).Row

'SARR(SJS, 1) &Chr(10) &Right(SARR(SJS, 2), 4)

'mytext = Left(.Cells(I, lh + 1).Text, 3) &Right(.Cells(I, lh + 1).Text, 4)

MYTEXT = qczf(.Cells(I, lh).Text) &"" &qczf(.Cells(I, lh + 1).Text)

If zjZD.EXISTS(MYTEXT) Then

.Cells(I, lh + 2) = dj

End If

Next I

End With

End Sub

Private Sub Frame2_Click()

xxx = 1

End Sub

Private Sub UserForm_Initialize()

Dim xstr(1 To 6) As String    '保存每列的数据

Dim ystr(1 To 3) As String

Dim zstr(1 To 15) As Integer '

xstr(1) = "A"

xstr(2) = "B"

xstr(3) = "C"

xstr(4) = "D"

xstr(5) = "E"

xstr(6) = "F"

ComboBox1.List = xstr

ystr(1) = "一等奖"

ystr(2) = "二等奖"

ystr(3) = "三等奖"

ComboBox2.List = ystr

For I = 1 To 15

zstr(I) = I

Next I

ComboBox3.List = zstr

ComboBox3.Value = 15

End Sub

参加年会最令人兴奋的部分是什么？当然是抽奖环节啦。抽奖活动可以使年会的气氛更加活跃，并为公司提供员工福利的一种方式，增强公司的凝聚力。如果年会策划的抽奖内容是彩票方法，那就太没有创新性了，很难激发员工的参与热情。以下这七种新颖、有趣的年会抽奖方式可以使年会抽奖环节更加新鲜。

1、电脑数字随机抽奖程序员事先在电脑上设计好数字程序，员工进场的时候逐一分发好号码牌，到抽奖环节，电脑可以根据事先分发的数字范围随机跳动数字，主持人喊停，停在屏幕上的数字就是中奖号码。

2、九宫格有奖问答程序员事先在电脑上设置好九宫格的问题，年会抽奖环节，主持人根据入场号码牌抽取号码进行有奖问答。

3、支付宝红包口令主持人可以把支付宝红包口令岩链猜显示在大屏幕上，在场人员听指示输入口令领取红包。

4、凳子下面寻宝会场布置人员事先在凳子下面粘贴好装入奖品券的信封，主持人在抽奖环节可以公布，坐到有信封的凳子可以凭奖品券兑换奖品。

5、微信摇一摇程序员事先设置好微信摇一摇中的程序，在抽奖环节，根据大屏幕显示的信息参与摇一摇活动，靠手机摇取奖品粗型。

6、员工照片墙展示大屏幕上显示出员工的照片，光标不断在照片墙上来回滚动，待主持人按住锁定一个员工的照片，即为中奖者。

7、集五福中大奖员工进场前分发一张福卡，随后在用餐的过程中，可以在碗碟下或者餐椅上粘贴五福卡，让员工自己发掘，员工之间也可以结盟凑齐五福卡，年会结束前可以集齐五福卡就可以兑换大奖。

以上是员工参与度具有气氛的抽奖方式，极大活跃了年会的氛围，有唤团的抽奖方式事先准备工作比较繁琐，耗时耗力。然而现在企业的年会形式越来越趋向移动智能化，员工可以进行微信扫码签到，微信头像以3D形式显示。大屏幕抽奖，微信可实时查看中奖名单。员工可在微信上发表d幕，显示在大屏幕上活跃气氛，还可实时投票参与选举，公平公正公开，同时还可参与微信摇一摇抢红包大战等年会抽奖方式。

用抓签这个传统的老办法就行，但并不新颖啊。事先做好500左右个签，在这里设斗拿置好你要设置的奖项及数量，如：你要设置1个特等奖，2个一等奖，3个二等奖，10个三等奖，140个幸运奖，就事先按你的计划数在签上做好这些各自标志，或在签上注明是什么奖项。然后与没有奖的空白签混到一起，在抓签时旦谨每人只能抓一次，而却只能是抓一个，这样不就OK了空迟搭嘛！

---