EXCEL VBA实现随机数抽奖

EXCEL VBA实现随机数抽奖

python 复制代码
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
相关推荐
神奇夜光杯1 小时前
Python酷库之旅-第三方库Pandas(202)
开发语言·人工智能·python·excel·pandas·标准库及第三方库·学习与成长
小c君tt2 小时前
MFC中Excel的导入以及使用步骤
c++·excel·mfc
一名技术极客5 小时前
Vue2 doc、excel、pdf、ppt、txt、图片以及视频等在线预览
pdf·powerpoint·excel·文件在线预览
用余生去守护5 小时前
【反射率】-- Lab 转换(excel)
excel
进击的六角龙5 小时前
Python中处理Excel的基本概念(如工作簿、工作表等)
开发语言·python·excel
TracyDemo5 小时前
excel功能
excel
lc寒曦5 小时前
【VBA实战】用Excel制作排序算法动画
排序算法·excel·vba
zzzgd8165 小时前
easyexcel实现自定义的策略类, 最后追加错误提示列, 自适应列宽,自动合并重复单元格, 美化表头
java·excel·表格·easyexcel·导入导出
努力学习技能的LY5 小时前
Excel:vba实现批量插入图片批注
excel
图片转成excel表格6 小时前
wps怎么算出一行1和0两种数值中连续数值1的个数,出现0后不再计算?
excel·wps