最近有粉絲在后臺向我提了一個工作中的小需求，具體如下：
■ 因為公司要組織一個知識競賽，其中有一個游戲環節，需要從一組名單中隨機選出指定數量的人員參加游戲，并且需要在大屏中滾動名單以增強游戲緊張感。當然最重要的是最終被選中的名單中不能有重復名單出現。她希望能通過Excel來實現這個需求。
需求分析：其實這個需求與抽獎非常類似，我們可以通過Excel的VBA宏功能來編寫一個小工具來實現這個需求，說干就干，以下就是最終實現的成品效果：
抽獎小工具演示
功能說明：
第1步、名單在sheet2《名單維護》工作表的A列中輸入
第2步、設置抽獎人數
第3步、點擊開始按鈕，名單開始滾動
第4步、點擊停止按鈕，出現獲獎人員名單
制作步驟如下：
第一步：制作表格
- 建立兩個工作表，分別為《抽獎頁面》和《名單維護》頁面。將待抽獎名單放在《名單維護》頁的A列，其中A1單元格為標題
第二步：編寫代碼
- 點擊開發工具-Visual Basic, 或按下快捷鍵 ALT + F11 啟動 Visual Basic for Applications 窗口
- 在“插入” 菜單上，單擊“模塊”
- 在出現的模塊1代碼窗口中，復制并粘貼以下代碼：
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If
Dim mark As Boolean
Sub 立即開始()
mark = True
Do While mark
DoEvents
Sleep 100
抽獎
Loop
End Sub
Sub 停止抽獎()
mark = False
End Sub
Sub 抽獎()
Dim M&, N&, i&, j&, arr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
arr = Sheet2.Range("A2:A" & Sheet2.Range("A65536").End(xlUp).Row)
Range("B4:B65536").ClearContents
M = Range("D4")
N = UBound(arr)
If N < M Then MsgBox "人數超出" & N: Exit Sub
Do While i < M
j = Int(Rnd() * N + 1)
If Not d.exists(j) Then
i = i + 1
d(j) = arr(j, 1)
End If
Loop
Range("B4").Resize(d.Count, 1) = Application.Transpose(d.items)
End Sub
寫入代碼
第三步：插入命令按鈕
- 通過開發工具——插入——Active控件，插入一個命令按鈕
- 雙擊這個命令按鈕，輸入過程名“立即開始”，并將這個按鈕的caption屬性改為“開始”
- 重復以上步驟再插入一個命令按鍵，輸入過程名“停止抽獎”，并將這個按鈕的caption屬性改為“停止”
插入命令按鈕
第四步：名單演示美化
- 利用條件格式設置名單的填充色和字體顏色
- 利用公式確定要設置格式的單元格：=B1<>""
設置格式
總結：
這個小工具的核心是：利用了字典+數組實現了名單的隨機不重復抽取。
如果你也有類似的需求，可以關注本頭條號：千萬別學Excel，并私信回復：小工具 即可獲取本教程所用課件。
圖文教程創作不易，請點贊、關注并轉發給更多有需求的小伙伴們吧！
送人玫瑰，手有余香！
