最近有粉絲在後台向我提了一個工作中的小需求，具體如下：

■ 因為公司要組織一個知識競賽，其中有一個遊戲環節，需要從一組名單中随機選出指定數量的人員參加遊戲，并且需要在大屏中滾動名單以增強遊戲緊張感。當然最重要的是最終被選中的名單中不能有重複名單出現。她希望能通過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，并私信回複：小工具 即可獲取本教程所用課件。

圖文教程創作不易，請點贊、關注并轉發給更多有需求的小夥伴們吧！

送人玫瑰，手有餘香！

更多精彩资讯请关注tft每日頭條，我们将持续为您更新最新资讯!