EXCEL VBA实现随机数抽奖
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Option Base 1
Public 行1, 列1, 行, 列
Private Sub CommandButton1_Click()
Sheet1.Activate
If CommandButton1.Caption = "停!" Then
CommandButton1.Caption = "开始"
Exit Sub
Else
CommandButton1.Caption = "停!"
行 = 1
列 = 1
行1 = 1
列1 = 1
End If
行数 = Val(MultiPage1.page2.TextBox1.Value)
列数 = Val(MultiPage1.page2.TextBox2.Value)
间隔 = Val(MultiPage1.page2.TextBox3.Value)
重复 = MultiPage1.page2.CheckBox1.Value
记录行 = Sheet2.Range("M65536").End(xlUp).Row
Dim arr()
ReDim arr(行数, 列数)
'将可抽单元格值,填入数组,以加快速度
For m = 1 To 行数
For n = 1 To 列数
arr(m, n) = Cells(m, n)
If Cells(m, n).Interior.Color = 65535 And 重复 = False Then
arr(m, n) = ""
End If
Next n
Next m
Do While CommandButton1.Caption = "停!"
行 = Int(行数 * Rnd + 1)
列 = Int(列数 * Rnd + 1)
If arr(行, 列) <> "" Then
'恢复上一单元格底色
Cells(行1, 列1).Select
m = 行1
n = 列1
If Cells(m, n).Interior.Color <> 65535 Then '防止A1被选中后又被清除
If ((m Mod 2 = 0 And n Mod 2 = 0) Or (m Mod 2 = 1 And n Mod 2 = 1)) Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
Else
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
'设置在选单元格为蓝色
Cells(行, 列).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Label3.Caption = arr(行, 列)
Sleep 间隔
DoEvents
If CommandButton1.Caption = "开始" Then
'恢复上一单元格底色
m = 行1
n = 列1
If Cells(m, n).Interior.Color <> 65535 Then '防止A1被选中后又被清除
If ((m Mod 2 = 0 And n Mod 2 = 0) Or (m Mod 2 = 1 And n Mod 2 = 1)) Then
Cells(行1, 列1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End If
End If
'设置选中单元格为黄色
Cells(行, 列).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'将结果记录到名单表K列
记录行 = 记录行 + 1
With Sheet2
If .Cells(记录行, 11) = "" Then
.Cells(记录行, 11) = Val(.Cells(记录行 - 1, 11)) + 1
End If
.Cells(记录行, 12) = Now
.Cells(记录行, 13) = arr(行, 列)
End With
End If
行1 = 行
列1 = 列
End If
Loop
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Sheet1.Activate
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
行数 = TextBox1.Value
列数 = TextBox2.Value
For m = 1 To 行数
For n = 1 To 列数
If (m Mod 2 = 0 And n Mod 2 = 0) Or (m Mod 2 = 1 And n Mod 2 = 1) Then
With Cells(m, n).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End If
Next n
Next m
Range("w3").Select
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheet1.Activate
Cells.ClearContents
行数 = Val(MultiPage1.page2.TextBox1.Value)
列数 = Val(MultiPage1.page2.TextBox2.Value)
行 = 1
列 = 1
With Sheet2
For m = 2 To Sheet2.UsedRange.Rows.Count
For n = 1 To 10
If .Cells(m, n) <> "" Then
Cells(行, 列) = .Cells(m, n)
行 = 行 + 1
If 行 > 行数 Then
行 = 1
列 = 列 + 1
If 列 > 列数 And Application.CountA(Sheet2.Range("a:j")) - 1 > 行数 * 列数 Then
MsgBox "名单个数超过指定行列所能容纳的总数！"
Exit Sub
End If
End If
End If
Next n
Next m
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "名单已填写完成！"
End Sub
Private Sub MultiPage1_Change()
End Sub
Private Sub UserForm_Initialize()
MultiPage1.page2.TextBox1.Value = 6
MultiPage1.page2.TextBox2.Value = 10
MultiPage1.page2.TextBox3.Value = 50
MultiPage1.page2.CheckBox1.Value = False
MultiPage1.page1.Label3.Caption = "中奖人"
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = True
End Sub
'Private Sub CommandButton1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
' If KeyAscii = 32 Then
' Call CommandButton1_Click
' ElseIf KeyAscii = 13 Then
' Call CommandButton1_Click
' End If
'End Sub