Simone如何用excel vba编写可以滚动的抽奖程序
的有关信息介绍如下：
公司里做活动，常常需要抽奖。网上大部分抽奖程序都是一下子给出结果了，而不像电视上面的那样，不停的滚动，不能抓住观众的视线。我自己动手编写了一个，在此介绍给大家。
工作表1，程序主界面，如图。此例中一共四个奖项，三等，二等，一等和特等，分别是5个，5个，3个和1个获奖人。如果获奖人未到场，可以点中TA的名字，点击"Get a Bckup"按钮，进行替换。
工作表2，候选人名单，在A列连续输入即可
VBA代码：
Private Declare Sub sleep Lib "kernel32" (ByVal dwmilliseconds As Long)Dim d1 As New DictionaryDim is_stop As BooleanDim arr, i, j, kDim d As New Dictionary
Private Sub btn_BUP_Click()btn_Get.Enabled = Falsebtn_BUP.Enabled = FalseIf Selection.Cells.Count = 1 ThenIf (Selection.Cells.Column = 1 And Selection.Cells.Row > 7) Or (Selection.Cells.Column = 2 And Selection.Cells.Row > 7) Or _(Selection.Cells.Column = 3 And Selection.Cells.Row > 5) Or (Selection.Cells.Column = 4 And Selection.Cells.Row > 3) Or _(Selection.Cells.Column > 4) Then MsgBox "Please select the right cell." btn_Get.Enabled = True btn_BUP.Enabled = True Exit SubEnd IfSheet1.btn_Stop.Enabled = True
arr = Sheets(2).UsedRangeWhile is_stop = False DoEvents i = 0 Do While i < 1 j = Int(Rnd() * UBound(arr) + 1) If (Not d.exists(j)) And (Not d1.exists(j)) Then i = i + 1 d(j) = arr(j, 1) If is_stop Then d1(j) = arr(j, 1) End If Loop Selection.Resize(d.Count, 1) = Application.Transpose(d.items) d.RemoveAllWendis_stop = FalseElseMsgBox "Please select only one cell." ' & vbnewline & vbnewline & Please select the right cell!"btn_Get.Enabled = Truebtn_BUP.Enabled = TrueExit SubEnd Ifbtn_Get.Enabled = Truebtn_BUP.Enabled = TrueEnd Sub
Private Sub btn_Get_Click()'Chao Ma'11/19/2014'toni8330@gmail.combtn_BUP.Enabled = Falsebtn_Get.Enabled = False
arr = Sheets(2).UsedRangeSelect Case btn_Get.Caption Case "Ready" btn_Get.Caption = "Get the third Prize" Sheets(1).Range("A3:D18").ClearContents Case "Get the third Prize" Sheet1.btn_Stop.Enabled = True 'btn_Get.Caption = "Stop" 'Range("A2:A7").Select 'ActiveSheet.Unprotect ' DrawingObjects:=True, Contents:=True, Scenarios:=True Range("A2:A7").Borders(xlDiagonalDown).LineStyle = xlNone Range("A2:A7").Borders(xlDiagonalUp).LineStyle = xlNone With Range("A2:A7").Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("A2:A7").Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("A2:A7").Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("A2:A7").Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Range("A2:A7").Borders(xlInsideVertical).LineStyle = xlNone While is_stop = False DoEvents i = 0 Do While i < 5 j = Int(Rnd() * UBound(arr) + 1) If (Not d.exists(j)) And (Not d1.exists(j)) Then i = i + 1 d(j) = arr(j, 1) If is_stop Then d1(j) = arr(j, 1) End If Loop Range("a3").Resize(d.Count, 1) = Application.Transpose(d.items) d.RemoveAll Wend btn_Get.Caption = "Get the second Prize" is_stop = False 'ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True Case "Get the second Prize" Sheet1.btn_Stop.Enabled = True 'ActiveSheet.Unprotect' Range("A2:A7").Select Range("A2:A7").Borders(xlDiagonalDown).LineStyle = xlNone Range("A2:A7").Borders(xlDiagonalUp).LineStyle = xlNone Range("A2:A7").Borders(xlEdgeLeft).LineStyle = xlNone Range("A2:A7").Borders(xlEdgeTop).LineStyle = xlNone Range("A2:A7").Borders(xlEdgeBottom).LineStyle = xlNone Range("A2:A7").Borders(xlEdgeRight).LineStyle = xlNone Range("A2:A7").Borders(xlInsideVertical).LineStyle = xlNone Range("A2:A7").Borders(xlInsideHorizontal).LineStyle = xlNone ' Range("B2:B7").Select Range("B2:B7").Borders(xlDiagonalDown).LineStyle = xlNone Range("B2:B7").Borders(xlDiagonalUp).LineStyle = xlNone With Range("B2:B7").Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("B2:B7").Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("B2:B7").Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("B2:B7").Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Range("B2:B7").Borders(xlInsideVertical).LineStyle = xlNone While is_stop = False DoEvents i = 0 Do While i < 5 j = Int(Rnd() * UBound(arr) + 1) If (Not d.exists(j)) And (Not d1.exists(j)) Then i = i + 1 d(j) = arr(j, 1) If is_stop Then d1(j) = arr(j, 1) End If Loop Range("b3").Resize(d.Count, 1) = Application.Transpose(d.items) d.RemoveAll Wend btn_Get.Caption = "Get the first Prize" is_stop = False 'ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True Case "Get the first Prize" Sheet1.btn_Stop.Enabled = True 'ActiveSheet.Unprotect' Range("B2:B7").Select Range("B2:B7").Borders(xlDiagonalDown).LineStyle = xlNone Range("B2:B7").Borders(xlDiagonalUp).LineStyle = xlNone Range("B2:B7").Borders(xlEdgeLeft).LineStyle = xlNone Range("B2:B7").Borders(xlEdgeTop).LineStyle = xlNone Range("B2:B7").Borders(xlEdgeBottom).LineStyle = xlNone Range("B2:B7").Borders(xlEdgeRight).LineStyle = xlNone Range("B2:B7").Borders(xlInsideVertical).LineStyle = xlNone Range("B2:B7").Borders(xlInsideHorizontal).LineStyle = xlNone 'Range("C2:C5").Select Range("C2:C5").Borders(xlDiagonalDown).LineStyle = xlNone Range("C2:C5").Borders(xlDiagonalUp).LineStyle = xlNone With Range("C2:C5").Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("C2:C5").Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("C2:C5").Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("C2:C5").Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Range("C2:C5").Borders(xlInsideVertical).LineStyle = xlNone While is_stop = False DoEvents i = 0 Do While i < 3 j = Int(Rnd() * UBound(arr) + 1) If (Not d.exists(j)) And (Not d1.exists(j)) Then i = i + 1 d(j) = arr(j, 1) If is_stop Then d1(j) = arr(j, 1) End If Loop Range("c3").Resize(d.Count, 1) = Application.Transpose(d.items) d.RemoveAll Wend btn_Get.Caption = "Get the GRAND Prize" is_stop = False 'ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True Case "Get the GRAND Prize" Sheet1.btn_Stop.Enabled = True 'ActiveSheet.Unprotect 'Range("C2:C5").Select Range("C2:C5").Borders(xlDiagonalDown).LineStyle = xlNone Range("C2:C5").Borders(xlDiagonalUp).LineStyle = xlNone Range("C2:C5").Borders(xlEdgeLeft).LineStyle = xlNone Range("C2:C5").Borders(xlEdgeTop).LineStyle = xlNone Range("C2:C5").Borders(xlEdgeBottom).LineStyle = xlNone Range("C2:C5").Borders(xlEdgeRight).LineStyle = xlNone Range("C2:C5").Borders(xlInsideVertical).LineStyle = xlNone Range("C2:C5").Borders(xlInsideHorizontal).LineStyle = xlNone' 'Range("D2:D3").Select Range("D2:D3").Borders(xlDiagonalDown).LineStyle = xlNone Range("D2:D3").Borders(xlDiagonalUp).LineStyle = xlNone With Range("D2:D3").Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("D2:D3").Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("D2:D3").Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Range("D2:D3").Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Range("D2:D3").Borders(xlInsideVertical).LineStyle = xlNone While is_stop = False DoEvents i = 0 Do While i < 1 j = Int(Rnd() * UBound(arr) + 1) If (Not d.exists(j)) And (Not d1.exists(j)) Then i = i + 1 d(j) = arr(j, 1) If is_stop Then d1(j) = arr(j, 1) End If Loop Range("d3").Resize(d.Count, 1) = Application.Transpose(d.items) d.RemoveAll Wend btn_Get.Caption = "Print as PDF" is_stop = False 'Range("D2:D3").Select Range("D2:D3").Borders(xlDiagonalDown).LineStyle = xlNone Range("D2:D3").Borders(xlDiagonalUp).LineStyle = xlNone Range("D2:D3").Borders(xlEdgeLeft).LineStyle = xlNone Range("D2:D3").Borders(xlEdgeTop).LineStyle = xlNone Range("D2:D3").Borders(xlEdgeBottom).LineStyle = xlNone Range("D2:D3").Borders(xlEdgeRight).LineStyle = xlNone Range("D2:D3").Borders(xlInsideVertical).LineStyle = xlNone Range("D2:D3").Borders(xlInsideHorizontal).LineStyle = xlNone 'Range("C7").Select Range("A2:D2").Borders(xlDiagonalDown).LineStyle = xlNone Range("A2:D2").Borders(xlDiagonalUp).LineStyle = xlNone Range("A2:D2").Borders(xlEdgeLeft).LineStyle = xlNone Range("A2:D2").Borders(xlEdgeTop).LineStyle = xlNone With Range("A2:D2").Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Range("A2:D2").Borders(xlEdgeRight).LineStyle = xlNone Range("A2:D2").Borders(xlInsideVertical).LineStyle = xlNone Range("A2:D2").Borders(xlInsideHorizontal).LineStyle = xlNone 'ActiveSheet.protect DrawingObjects:=True, Contents:=True, Scenarios:=True Case "Print as PDF" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ Environ("UserProfile") & "\Desktop\LuckyDraw_MS.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ True btn_Get.Caption = "Ready" is_stop = FalseEnd Selectbtn_BUP.Enabled = Truebtn_Get.Enabled = TrueEnd Sub
Private Sub btn_Stop_Click()is_stop = TrueSheet1.btn_Stop.Enabled = FalseEnd Sub
工作簿打开时清理上次结果
Private Sub Workbook_Open()Sheets(1).Range("A3:D18").ClearContentsSheet1.btn_Get.Caption = "Ready"
Sheet1.btn_Stop.Enabled = False
End Sub
