如何实现人员抽点的时候抽到指定人员，而不是随机人员。

Question

单位有个竞赛活动，然后用PPT做了个人员抽点的小程序，需要最后控制人员抽点的顺序，抽到特定的人员，但是不知道怎么实现这个效果，现求助大佬。

Dim flag As Integer '全局变量用于查询是否按下停止键


Sub delay(T As Single)
  Dim time1 As Single
  time1 = Timer
  Do
     DoEvents
  Loop While Timer - time1 < T
End Sub


Private Sub 开始_Click()

flag = 0

'Dim StuData(500) As Person
'StuData() = 0
Dim StuData(500) As String
Dim buf As String
Dim i As Integer
i = 0



Open "E:\人员名册.txt" For Input As #1
'Open "E:\output.txt" For Output As #2

Do While Not EOF(1)
    Line Input #1, buf
    'Write #2, buf
    StuData(i) = buf
    i = i + 1

    '在循环中将姓名输入数组

Loop

'Close #1
'Close #2
Dim index As Integer
Dim tims As Integer
times = 0

'循环显示姓名1
Do Until (times > 65534 Or flag <> 0)

index = Int((i * Rnd) + 0)
Label1.Caption = StuData(index)
times = times + 1
delay (0.05)

Loop

Close #1

End Sub

Private Sub 停止_Click()
flag = 1

End Sub

用到的代码就是以上代码

Answer 1

使用方法，编辑names文件，每个名字1行
注意，需要抽取的人，名字后面加上一个空格
不希望抽取的人，不要加
则程序滚动的时候，所有人都参与滚动，停止的时候，有空格的才会出来

Option Explicit

Private isRunning As Boolean
Dim names() As String

Private Sub CommandButton1_Click()
    CommandButton1.Enabled = False
    Dim filecontent As String
    Open "names.txt" For Binary As #1
        filecontent = Input(LOF(1), #1)
    Close #1
    names = Split(filecontent, vbCrLf)
    Randomize
    isRunning = True
    While isRunning
        TextBox1.Text = RndName(False)
        DoEvents
    Wend
    TextBox1.Text = RndName(True)
    If TextBox1.Text = "" Then CommandButton1.Enabled = True: Exit Sub
    If Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text <> "" Then Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text = Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text & ","
    Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text = Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text & TextBox1.Text
    CommandButton1.Enabled = True
End Sub

Private Function RndName(isSpec As Boolean) As String
    Dim cnt As Long
    cnt = 1
    Dim idx As Long
    Do
        cnt = cnt + 1
        If cnt > 99999 Then
            RndName = ""
            Exit Function
        End If
        idx = Int(Rnd * (UBound(names) - LBound(names) + 1)) + LBound(names)
        If Not IsExist(names(idx)) Then
            If isSpec Then
                If (names(idx) <> Trim(names(idx))) Then
                    RndName = Trim(names(idx))
                    Exit Do
                End If
            Else
                RndName = Trim(names(idx))
                Exit Do
            End If
        End If
    Loop
End Function

Private Function IsExist(name As String) As Boolean
    Dim arr() As String
    arr = Split(Me.Application.ActivePresentation.Slides(2).Shapes(6).TextFrame.TextRange.Text, ",")
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If Trim(name) = Trim(arr(i)) Then
            IsExist = True
            Exit Function
        End If
    Next
    IsExist = False
End Function

Private Sub CommandButton2_Click()
    isRunning = False
End Sub

其他人如果也需要：https://download.csdn.net/download/caozhy/11311604