【VBA】excel随机抽选三名女朋友
# 制作原因最近女朋友太多,想随机抽选几个女朋友约会，遂制作该表格。
## 功能
1. 不重复滚动随机抽选三名女朋友
2. 检测来不了的女朋友，再次抽选填充该位置
## 未完成功能
1. 将抽选的女朋友，生成审批单报老板审阅。
2. 记录抽选记录
## 界面如下图
[!(https://z3.ax1x.com/2021/09/02/hrI9q1.png)](https://imgtu.com/i/hrI9q1)
## vba代码
```
Sub delay(T As Single) '这个是定义延时命令的
Dim time1 As Single
time1 = Timer
Do
DoEvents
Loop While Timer - time1 < T
End Sub
Sub 清除名单()
Range("A4:G65536").ClearContents
End Sub
Sub 开始() '开始抽选代码从这里开始
If Sheet1.Buttons(Application.Caller).Caption = "停止抽选" Then'判断当前点击按钮上的文字 如果为"停止抽选" 则修改为"开始抽选"
Sheet1.Buttons(Application.Caller).Caption = "开始抽选"
ElseIf Sheet1.Buttons(Application.Caller).Caption = "开始抽选" Then '判断当前点击按钮上的文字 如果为"开始抽选" 则修改为"停止抽选"并开始运行抽选代码
Sheet1.Buttons(Application.Caller).Caption = "停止抽选"
Call 开始抽选
End If
End Sub
Sub 开始抽选()
Sheet2.Range("T:BZ").ClearContents '清除P到BA列内容 防止出错
'Sheet2.Columns("AA").Resize(, 10).Delete '删除AA列往后的10列
hang = Sheet2.Range("B65536").End(xlUp).Row '取B列最后一行的行号
'lie = Sheet2.Cells(2, Columns.count).End(xlToLeft).Column '取第二行最后一列单元格的列号
helpRow = 1 '辅助列的起始行号
For dataRow = 3 To hang'从第三行到最后一行开始循环
flag = 0 '符合条件的个数重置为0
selectCon = condition()
If InStr(1, Sheet2.Cells(dataRow, "F"), selectCon) > 0 Or Sheet2.Cells(dataRow, "F") = "" Then '判断F列每一个单元格是否符合条件 如果符合条件那么符合条件个数也就是jishu+1
flag = flag + 1
End If
If flag > 0 Then '如果大于0也就是说至少有一个条件符合了 那么把这一行复制到辅助列AA列处
helpRow = helpRow + 1 ' 辅助列行数+1
Sheet2.Range("A" & dataRow & ":G" & dataRow).Copy Sheet2.Cells(helpRow, "AA")
Sheet2.Cells(helpRow, "AH") = dataRow
End If
Next
break = 1 '重复循环跳出标志
'判空操作
If IsEmpty(Sheet1.Range("A4").Value) Then
sdatarow = 4
ElseIf IsEmpty(Sheet1.Range("A5").Value) Then
sdatarow = 5
ElseIf IsEmpty(Sheet1.Range("A6").Value) Then
sdatarow = 6
Else
Sheet1.[按钮 1].Caption = "开始抽选"
Sheet1.[按钮 1].Enabled = False
MsgBox prompt:="抽选名单已满三人！", Buttons:=vbOKOnly + vbInformation, Title:="提示"
Exit Sub
End If
Do
If Sheet1.Buttons(Application.Caller).Caption = "开始抽选" Then Exit Do'循环随机打乱 并判断按钮状态 如果按钮文字为开始抽选则停止循环开始提取结果
AAA:
delay (0.01)
randomNum = Application.RandBetween(2, helpRow)
hang = Sheet2.Cells(randomNum, "AH") '将命中的行号赋给行
If break = 20 Then '跳出判断
Sheet1.[按钮 1].Caption = "开始抽选"
Sheet1.[按钮 1].Enabled = False
MsgBox prompt:="没有更多可满足条件的专家抽选了", Buttons:=vbExclamation, Title:="提示"
Exit Do
End If
If sdatarow = 4 Then
If Sheet2.Cells(hang, "B") = Cells(sdatarow + 1, "B") Or Sheet2.Cells(hang, "B") = Cells(sdatarow + 2, "B") Then'判断重复
break = break + 1
GoTo AAA '判断重复，若重复再次筛选
End If
ElseIf sdatarow = 5 Then
If Sheet2.Cells(hang, "B") = Cells(sdatarow - 1, "B") Or Sheet2.Cells(hang, "B") = Cells(sdatarow + 1, "B") Then '判断重复
break = break + 1
GoTo AAA '判断重复，若重复再次筛选
End If
ElseIf sdatarow = 6 Then
If Sheet2.Cells(hang, "B") = Cells(sdatarow - 1, "B") Or Sheet2.Cells(hang, "B") = Cells(sdatarow - 2, "B") Then '判断重复
break = break + 1
GoTo AAA '判断重复，若重复再次筛选
End If
End If
delay (0.1) '延迟时间 也就是滚动速度 单位为秒数字越小滚动越快
Sheet1.Range("A" & sdatarow & ":G" & sdatarow).Interior.Color = 10079487
Sheet2.Range("A" & hang & ":G" & hang).Copy Sheet1.Range("A" & sdatarow)
Loop
sdatarow = sdatarow + 1
Sheet2.Columns("AA").Resize(, 10).Delete'删除辅助列
End Sub
Sub AddWorksheet()
Dim flag As Boolean
'新建sheet表
For Each Sheet In Sheets
If Sheet.Name = Date & "抽选结果" Then
flag = True
Exit For
End If
Next
If flag = False Then
Sheets.Add After:=Sheets(Sheets.count)
ActiveSheet.Name = Date & "抽选结果"
End If:
'格式保存
Sheets("专家库").Range("J5:P10").Copy
With Sheets(Date & "抽选结果").Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
End With
'Sheets(Date & "抽选结果").Range("A1").PasteSpecial Paste:=xlPasteFormats
Sheets(Date & "抽选结果").Cells(1, "A") = Date & "获选名单"
ThisWorkbook.Save
End Sub
Function condition()
Dim count As Integer
Set lst = Sheet1.[下拉框 5]
cValue = lst.List(lst.Value)
condition = cValue
End Function
```
## excel下载地址
https://wwa.lanzoui.com/i2R6lti6a2f
感谢@小小涩郎 SmileHmily 发表于 2021-9-2 17:31
我觉得明明是用几个函数就能解决的，突然被你弄的很复杂……
主要是老板不会 你可肾好？ hack528 发表于 2021-9-2 17:11
你可肾好？
要问老板 被召唤来了 {:301_997:} 来冒个泡 東西學到了請問女朋友去哪領 我觉得明明是用几个函数就能解决的，突然被你弄的很复杂…… 真他娘的是个天才:lol 到底是施工管理还是抽女朋友。。。 说好的女朋友呢？谢谢楼主分享，学习了。
页:
[1]
2