【原創】Excel VBA實現不重復、多次抽獎小程序

在活動中，我們常會有抽獎，抽獎箱准備繁瑣，現在多采用線上抽獎方式，下面用Excel VBA寫了一個簡單的抽獎小程序

簡單測試效果如下，可實現：

• 多次抽獎，且每次抽獎都不重復

• 抽獎界面滾動人員信息，點擊抽獎按鈕鎖定中獎人員

• 中獎人員信息在右側公示區域展示，最新中獎人員展示在最上方

• 設置了一部分誤點、誤操作提示，以及抽獎完成提示等

• 已優化，支持萬人級抽獎

做了一個抽獎簡單演示，演示GIF如下：

實現代碼如下，按需自取，轉載請備注出處：

'申明Flag、d、e三個模塊變量，跨進程引用，實現滾動和抽獎數據傳遞
Dim Flag As Boolean     '屏幕停止滾動並抽獎的判斷參數
Dim d As Object         '將隨機抽取的中獎人員按自增鍵儲存
Dim e As Object         '將隨機抽取的中獎人員按原鍵儲存
Dim dict_id As Object   '本輪參與抽獎人員工號


Sub 重置()

'清空上次抽獎內容，將人員名單復制到輔助列
Application.ScreenUpdating = False  '屏幕刷新禁用，不展示清空數據過程

Sheets("抽獎界面").Select
Sheets("抽獎界面").Range("E2") = 0
Sheets("抽獎界面").Range(Range("B6"), Range("F15")).ClearContents
Sheets("抽獎界面").Range(Range("J3"), Range("P3").End(xlDown)).ClearContents
Sheets("人員名單").Select
Sheets("人員名單").Range(Range("H3"), Range("H3").End(xlDown)).ClearContents
Sheets("人員名單").Range(Range("A3"), Range("A3").End(xlDown)).Copy _
Sheets("人員名單").Range("H3")
Sheets("抽獎界面").Select

Application.ScreenUpdating = True   '屏幕刷新開啟，為滾動抽獎做准備

End Sub


Sub 准備()  '准備開始抽獎，灰色區域滾動更新中獎人員

Set d = Nothing
Set e = Nothing
Set dict_id = Nothing
Flag = True

text_level = Sheets("抽獎界面").Range("A2")       '抽取獎項
lottery_target = Sheets("抽獎界面").Range("D2")   '抽獎次數目標

'判斷該獎項是否已經抽取過，當變更了抽取獎項時，自動重置已抽取次數為0
If Application.WorksheetFunction.CountIfs(Sheets("抽獎界面").Range("J:J"), _
text_level) = 0 Then    
    Sheets("抽獎界面").Range("E2") = 0    
End If

'判斷剩余參與人數是否足夠抽獎
If Sheets("抽獎界面").Range("F2") < Sheets("抽獎界面").Range("C2") Then
    MsgBox ("剩余參與人數不足，請修改抽獎參數或停止抽獎！！！")    
    Exit Sub    
End If

'判斷該獎項是否已抽取完，提示操作人員是選擇加抽還是變更抽獎獎項
If Sheets("抽獎界面").Range("E2") >= lottery_target Then
    QS_Return = MsgBox(text_level & "抽獎" & lottery_act & "已完成！" & _
Chr(10) & "要變更獎項請選擇是" & Chr(10) & "要再次抽取" & text_level & _
"請選擇否", vbYesNo + vbQuestion, "提示")
    If QS_Return = vbYes Then    
        MsgBox (text_level & "請重新選擇獎項，輸入抽獎次數和單次抽獎人數！")    
        Exit Sub        
    Else    
        Sheets("抽獎界面").Range("D2") = Sheets("抽獎界面").Range("D2") + _
Sheets("抽獎界面").Range("E2")        
    End If    
End If

'清空抽獎滾動區域
Sheets("抽獎界面").Range(Range("B6"), Range("F15")).ClearContents
num_agent = Sheets("抽獎界面").Range("F2")

'字典賦值
Set dict_id = CreateObject("Scripting.Dictionary")
For i = 1 To num_agent
    dict_id(i) = Sheets("人員名單").Cells(i + 2, 8)    
Next
num = Sheets("抽獎界面").Range("C2")

'持續滾動抽獎界面，等待點擊抽獎后停止
Do
    Set d = CreateObject("Scripting.Dictionary")
    Set e = CreateObject("Scripting.Dictionary")
    For j = 1 To num    
        Do        
            a = Int(Rnd * num_agent) + 1        
        Loop Until Not e.Exists(a)                
        d(j) = dict_id(a)                
        e(a) = dict_id(a)    
    Next    
    For m = 1 To 10        
        For n = 1 To 5            
            If n + (m - 1) * 5 > num Then            
                Exit For                
            Else            
                Sheets("抽獎界面").Cells(m + 5, n + 1) = d(n + (m - 1) * 5)                    
                DoEvents    '將控制權傳給操作系統，實現滾動的同時可以點擊抽獎按鈕，非常關鍵！！！                     
            End If            
        Next            
    Next    
Loop Until Flag = False

End Sub


Sub 抽獎()

If Not Flag Then
    MsgBox ("請先點擊准備按鈕，再開始抽獎！！！")    
    Exit Sub    
End If

Flag = False    '停止抽獎滾動，中獎人員確定
Set f = CreateObject("Scripting.Dictionary")
text_level = Sheets("抽獎界面").Range("A2")
Sheets("抽獎界面").Range("E2") = Sheets("抽獎界面").Range("E2") + 1     '已抽取次數+1
lottery_act = Sheets("抽獎界面").Range("E2") '已抽取次數，后面需要判斷是否提示抽獎完成
num = Application.WorksheetFunction.CountA(Sheets("抽獎界面").Range("B6:F15"))
num_exist = Sheets("抽獎界面").Range("G2")

'將新中獎人員信息添加至公示區域末尾
For i = 1 To num
    Sheets("抽獎界面").Cells(2 + num_exist + i, 10) = text_level   
    Sheets("抽獎界面").Cells(2 + num_exist + i, 11) = lottery_act   
    Sheets("抽獎界面").Cells(2 + num_exist + i, 12) = d(i)    
    Sheets("抽獎界面").Cells(2 + num_exist + i, 13) = _
Application.WorksheetFunction.VLookup(d(i), Sheets("人員名單").Range("A:E"), 2, False)    
    Sheets("抽獎界面").Cells(2 + num_exist + i, 14) = _
Application.WorksheetFunction.VLookup(d(i), Sheets("人員名單").Range("A:E"), 3, False)    
    Sheets("抽獎界面").Cells(2 + num_exist + i, 15) = _
Application.WorksheetFunction.VLookup(d(i), Sheets("人員名單").Range("A:E"), 4, False)    
    Sheets("抽獎界面").Cells(2 + num_exist + i, 16) = _
Application.WorksheetFunction.VLookup(d(i), Sheets("人員名單").Range("A:E"), 5, False)
Next

'將所有中獎人員存放至字典
For i = 1 To num_exist + num
    If i <= num Then
        f(i) = Sheets("抽獎界面").Range(Cells(num_exist + i + 2, 10), _
Cells(num_exist + i + 2, 16))        
    Else        
        f(i) = Sheets("抽獎界面").Range(Cells(i + 2 - num, 10), Cells(i + 2 - num, 16))        
    End If
Next

Sheets("抽獎界面").Range(Cells(3, 10), Cells(num_exist + num + 3, 16)).ClearContents
Sheets("抽獎界面").[J3].Resize(f.Count, 7).Value = _
Application.Transpose(Application.Transpose(f.items))

'獎項抽取完成后提示人員變更參數
If lottery_act = Sheets("抽獎界面").Range("D2") Then    
    MsgBox (text_level & "抽取" & lottery_act & "次已完成，請變更抽獎獎項和次數")    
End If

'更新待抽獎人員名單，實現不重復抽獎
num_agent = Sheets("抽獎界面").Range("F2")
Application.ScreenUpdating = False  '屏幕刷新禁用，不展示清空數據過程
Sheets("人員名單").Select

For Each Key In e
    dict_id.Remove (Key)
Next

Sheets("人員名單").Range(Range("H3"), Range("H3").End(xlDown)).ClearContents
Sheets("人員名單").[H3].Resize(dict_id.Count, 1).Value = _
Application.Transpose(dict_id.items)
Sheets("抽獎界面").Select

Application.ScreenUpdating = True   '屏幕刷新開啟，為下一輪滾動抽獎做准備

End Sub

功能實現思路：

• 通過隨機函數Rnd產生[0,1)的隨機數，再乘以當前參與人數放大，實現隨機抽獎

• 通過字典的Exists方法判斷是否重復，實現去重抽獎

• 定義模塊變量，實現人員滾動和抽獎的分離

• DoEvents語句將控制權傳給操作系統，實現滾動的同時可以點擊抽獎按鈕，是實現抽獎屏幕滾動更新的關鍵

• 最初以遍歷的方式回填數據，發現參與人數上萬時明顯卡頓，改用字典的items方法回填數據（一維數據回填到列：Application.Transpose(dict.items)，二維數據回填到列：Application.Transpose(Application.Transpose(dict.items))）