EXCEL VBA实现随机数抽奖

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