EXCEL抽奖如何多次抽奖不重复excel抽奖怎么不重复

发布网友 发布时间：2024-05-14 16:03

我来回答

共1个回答

热心网友 时间：2024-05-16 04:52

用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
　　抽取不重复的很好办到，比如抽取后单独做标记、去除等等办法。但最关键的部分恰恰是被你忽略的：随机性。也就是你需要如何来实现你随机抽取这个过程。抽号这个你可以跑号、随机数这些都可以。