【VBA】excel随机抽选三名女朋友

人二

制作原因

最近女朋友太多,想随机抽选几个女朋友约会，遂制作该表格。

功能

1. 不重复滚动随机抽选三名女朋友
2. 检测来不了的女朋友，再次抽选填充该位置

未完成功能

1. 将抽选的女朋友，生成审批单报老板审阅。
2. 记录抽选记录

界面如下图

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

你可肾好？

人二

hack528 发表于 2021-9-2 17:11
你可肾好？

要问老板

小小涩郎

被召唤来了        来冒个泡   

夕魚

東西學到了  請問女朋友去哪領

SmileHmily

我觉得明明是用几个函数就能解决的，突然被你弄的很复杂……

piwei

真他娘的是个天才

mercio

到底是施工管理还是抽女朋友。。。

Wapj_Wolf

说好的女朋友呢？谢谢楼主分享，学习了。