原程式碼如下:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim uMode$, xDicA As Object, xDicB As Object
Sub 搖獎()
Dim x%, y%, xR As Range, k%, Km%, KK%
If uMode = "Start" Then Exit Sub
'----------------------------------------
x = [搖獎!A65536].End(xlUp).Row
If x < 2 Then MsgBox "※錯誤！無法取得〔獎品〕項目！": Exit Sub
Set xDicA = CreateObject("Scripting.Dictionary")
For Each xR In [搖獎!A2].Resize(x - 1)
Km = Val(xR(1, 4)) - Val(xR(1, 5))
If Km > 0 Then
For k = 1 To Km
KK = KK + 1: xDicA(KK) = xR.Row
Next k
End If
Next
If xDicA.Count = 0 Then MsgBox "※〔獎品〕已抽取完畢！": Exit Sub
'------------------------------------------------
KK = 0
y = [人員名單!A65536].End(xlUp).Row
If y < 2 Then MsgBox "※錯誤！無法取得〔人員名單〕項目！": Exit Sub
Set xDicB = CreateObject("Scripting.Dictionary")
For Each xR In [人員名單!A2].Resize(y - 1)
If xR(1, 3) = "" Then KK = KK + 1: xDicB(KK) = xR.Row
Next
If xDicB.Count = 0 Then MsgBox "※所有〔人員〕已抽獎完畢！": Exit Sub
'----------------------------------------
uMode = "Start"
Call 啟動
End Sub
Sub 停止()
uMode = "Stop"
[G5,G9,G11] = ""
End Sub
Sub 確定()
Dim AA%, BB%
If uMode <> "Start" Then Exit Sub
uMode = "Stop"
Randomize
AA = xDicA(Int(Rnd * xDicA.Count) + 1)
With Sheets("搖獎")
.Cells(AA, 5) = .Cells(AA, 5) + 1
.[G9] = .Cells(AA, 2)
.[G11] = .Cells(AA, 3)
End With
'-------------------------------------
BB = xDicB(Int(Rnd * xDicB.Count) + 1)
With Sheets("人員名單")
[搖獎!G5] = .Cells(BB, 2)
.Cells(BB, 3) = [搖獎!G9]
.Cells(BB, 4) = [搖獎!G11]
End With
ThisWorkbook.Save
Beep
End Sub
Sub 啟動()
Dim i%, j%
For i = 1 To 600
If uMode <> "Start" Then Exit Sub
For j = 1 To 5
[G5,G9,G11] = Mid(Rnd, 3, 6) & Mid(Rnd, 3, 6)
Sleep 2
Next j
DoEvents
Next i
Application.OnTime Now + TimeValue("00:00:01"), "啟動"
End Sub
Sub 清除CD欄()
[人員名單!C2:D6000].ClearContents
End Sub作者: q1a2z5 時間: 2017-2-5 22:29
