【EXCEL VBA】抽奖工具： 从N个姓名中随机抽出M个人（M<=N)

稍等，我给我写一个

sheet1表A列为姓名列（不限定人数），sheet2表的B2输入需要抽取的人数，如果大于名单人数，会提示超出并停止运行，否则在D列列出抽中名单（不重复，数组与字典相结合的方法完成）

用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("scriptingdictionary")

'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 = MeControls(myName)

xxBackColor = RGB(255, 255, 255)

xxForeColor = RGB(255, 215, 0)

xxFontSize = 10

xxBackStyle = 0

ZZ3 = ZZ3 - 1

If ZZ3 = 0 Then ZZ3 = 15

Next I

zb = ComboBox1Value

dj = ComboBox2Value

ZJRS = ComboBox3Value '中奖人数

'读取还可抽取人数

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 = MeControls(myName)

xxText = 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 zjZDEXISTS(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 = MeControls(myName)

'xxText = Left(SARR(SJS, 2), 3) & "XXXX" & Right(SARR(SJS, 2), 4)

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

zjZDRemoveAll

For I = 1 To ZJRS

myName = "TextBox" & I

Set xx = MeControls(myName)

If xxText <> "" Then

MYKEY2 = qczf(Left(xxText, InStr(xxText, Chr(10)) - 1)) & ";" & Right(xxText, 4)

zjZDAdd MYKEY2, I

End If

Next I

'xxBackColor = 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 = MeControls(myName)

xxBackColor = RGB(ysARR(1, 1), ysARR(1, 2), ysARR(1, 3))

xxForeColor = RGB(0, 0, 255)

xxFontSize = 20

xxBackStyle = 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 = ComboBox1Value '组别

dj = ComboBox2Value '等级

ZJRS = ComboBox3Value '中奖人数

Set zjZD = CreateObject("scriptingdictionary")

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

For I = 1 To ZJRS

myName = "TextBox" & I

Set xx = MeControls(myName)

ARR = Split(xxText, Chr(10))

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

zjZDAdd MYTEXT, I

xxText = ""

xxBackColor = 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 zjZDEXISTS(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"

ComboBox1List = xstr

ystr(1) = "一等奖"

ystr(2) = "二等奖"

ystr(3) = "三等奖"

ComboBox2List = ystr

For I = 1 To 15

zstr(I) = I

Next I

ComboBox3List = zstr

ComboBox3Value = 15

End Sub

用randbetween函数来生成随机数，然后用根据概率设置，用if来判断他应该落在哪个区间就行了，比如一等奖概率5%，可以这样写：

=IF(RANDBETWEEN(1,100) <=5, "恭喜你中了一等奖", "很遗憾未中奖")

如果是25%，把上面的5改成25就可以了

核心就是随机数的生成，至于怎么安排/显示/统计，就看你自己需要什么样的了（统计那个可以直接根据最终文字， 也可以把随机数拆解出来分多个公式计算）

以上就是关于【EXCEL VBA】抽奖工具： 从N个姓名中随机抽出M个人（M<=N)全部的内容，包括:【EXCEL VBA】抽奖工具： 从N个姓名中随机抽出M个人（M<=N)、EXCEL 抽奖 如何 多次抽奖不重复、请问怎么用Excel，按照固定的概率自动抽奖，统计实际结果等相关内容解答，如果想了解更多相关内容，可以关注我们，你们的支持是我们更新的动力！