如何用excel vba编写可以滚动的抽奖程序

1、工作表1，程序主界面，如图。此例中一共四个奖项，三等，二等，一等和特等，分别是5个，5个，3个和1个获奖人。如果获奖人未到场，可以点中TA的名字，点击"Get a Bckup"按钮，进行替换。

2、工作表2，候选人名单，在A列连续输入即可

3、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

4、工作簿打开时清理上次结果

Private Sub Workbook_Open()Sheets(1).Range("A3:D18").ClearContentsSheet1.btn_Get.Caption = "Ready"

Sheet1.btn_Stop.Enabled = False

End Sub