Excel VBA活動抽獎小程式

弓長無忌發表於2021-08-10
Excel

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

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

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

  • 抽獎介面滾動人員資訊，點選抽獎按鈕鎖定中獎人員

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

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

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

實現程式碼如下，按需自取，轉載請備註出處：

'申明Flag、d、e三個模組變數，跨程式引用，實現滾動和抽獎資料傳遞

Dim Flag As Boolean     '螢幕停止滾動並抽獎的判斷引數
Dim d As Object         '將隨機抽取的中獎人員按自增鍵儲存
Dim e As Object         '將隨機抽取的中獎人員按原鍵儲存


Sub 重置()

'清空上次抽獎內容，將人員名單複製到輔助列

Application.ScreenUpdating = False  '螢幕重新整理禁用，不展示清空資料過程

Sheets("抽獎介面").Select
Sheets("抽獎介面").Range("E2") = 0
Sheets("抽獎介面").Range(Range("B6"), Range("F15")).ClearContents
Sheets("抽獎介面").Range(Range("J3"), Range("M3").End(xlDown)).ClearContents
Sheets("人員名單").Select
Sheets("人員名單").Range(Range("E2"), Range("F2").End(xlDown)).ClearContents
Sheets("人員名單").Range(Range("A2"), Range("B2").End(xlDown)).Copy _
Sheets("人員名單").Range("E2")  '此行程式碼接前一行，複製後注意是否報錯
Sheets("抽獎介面").Select

Application.ScreenUpdating = True   '螢幕重新整理開啟，為滾動抽獎做準備

End Sub


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

Set d = Nothing
Set e = Nothing
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
Flag = True
Set dict_id = CreateObject("scripting.dictionary")

'變數、字典賦值
num_agent = Sheets("抽獎介面").Range("F2")
num = Sheets("抽獎介面").Range("C2")

For i = 1 To num_agent
    dict_id(i) = Sheets("人員名單").Cells(i + 1, 5)    
Next

'持續滾動抽獎介面，等待點選抽獎後停止
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 抽獎()

Dim m As Integer

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

Flag = False    '停止抽獎滾動，中獎人員確定
Set f = CreateObject("Scripting.Dictionary")
Set dict_agent = CreateObject("scripting.dictionary")
text_level = Sheets("抽獎介面").Range("A2")
Sheets("抽獎介面").Range("E2") = Sheets("抽獎介面").Range("E2") + 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("E:F"), 2, 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, 13))  '此行程式碼接前一行，複製後注意是否報錯        
    Else        
        f(i) = Sheets("抽獎介面").Range(Cells(i + 2 - num, 10), Cells(i + 2 - num, 13))        
    End If
Next

Sheets("抽獎介面").Range(Cells(3, 10), Cells(num_exist + num + 2, 13)).ClearContents

For j = 1 To num_exist + num
    Sheets("抽獎介面").Range(Cells(2 + j, 10), Cells(2 + j, 13)) = f(j)
Next

'獎項抽取完成後提示人員變更引數
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 k = 1 To num_agent
    If Not e.Exists(k) Then
        dict_agent(k) = Sheets("人員名單").Range(Cells(k + 1, 5), Cells(k + 1, 6))
    End IF
Next

Sheets("人員名單").Range(Cells(2, 5), Cells(num_agent + 1, 6)).ClearContents
m = 1

For Each Key In dict_agent
    Sheets("人員名單").Range(Cells(m + 1, 5), Cells(m + 1, 6)) = dict_agent(Key)    
    m = m + 1
Next

Sheets("抽獎介面").Select
Application.ScreenUpdating = True   '螢幕重新整理開啟，為下一輪滾動抽獎做準備

End Sub

相關文章