Option Explicit
Private Sub Command1_Click()
Dim nameArr(), mPath$, n%, k%, newDic, Temp$
mPath = "d:\Name.txt" '原始名單路徑，每行壹人
k = Int(InputBox("抽取的人數：")) '抽取的數目
'加載原始名單
Open mPath For Input As #1
Do While Not EOF(1)
n = n + 1
ReDim Preserve nameArr(1 To n)
Line Input #1, nameArr(n)
Loop
Close #1
'抽取人員
Set newDic = CreateObject("scripting.dictionary")
Do While newDic.Count < k
Randomize
Temp = nameArr(Int(Rnd * (UBound(nameArr) + 1)))
If newDic.Exists(Temp) = False Then newDic.Add Temp, ""
Loop
'輸出
Temp = Join(newDic.keys, ", ")
Print n & "名人員中，" & k; "名被抽取，名單如下：" & vbCrLf & Temp
newDic = ""
End Sub