用excel制作抽奖功能--“三好兔噢”抽奖方法公示

其实原理很简单，就是把比赛文章列表放到一个工作表（名为复制）中。

然后在另一个工作表中，放好称号，和称号总数。

然后在一个工作表里，制作一个按钮单元格，点击它，调用工作表“复制“里的数据，并为每篇参赛文章指定一个唯一的编号；

制作第二个按钮单元格，点击以后，按是否新人、综合评分、发文时间排序，然后为前三名指定称号；

制作第三个按钮单元格，点击以后，计算幸运奖名额，然后，随机生成数，乘以参与抽奖的文章总数，然后加上3.5，再四舍五入，可以得到中奖的编号。

代码如下：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    '初始化
    If Target.Address = "$AF$1" Then
        Static winner() As String
        Static winner_row() As Integer
        ReDim winner(0)
        ReDim winner_row(0)
        Range("B3:B102") = ""
        Range("D3:D102") = ""
        Range("F3:F102") = ""
        Range("H3:H102") = ""
        Range("J3:J102") = ""
        Range("L3:L102") = ""
        Range("N3:N102") = ""
        Range("P3:P102") = ""
        Range("R3:R102") = ""
        Range("T3:T102") = ""
        Range("U3:U102") = ""
        Range("V3:V102") = ""
        Range("W3:W102") = ""
        Range("X3:X102") = ""
        Range("Y3:Y102") = ""
        Range("Z3:Z102") = ""
        Range("AA3:AA102") = ""
        Range("AB3:AB102") = ""
            idno = 1
            idno_new = 1
        For i = 3 To Worksheets("列表").Range("B112") + 2
            
            Range("D" + CStr(i)).Formula = "=复制!A" + CStr(i - 2)
            Range("F" + CStr(i)).Formula = "=复制!B" + CStr(i - 2)
            Range("H" + CStr(i)).Formula = "=复制!C" + CStr(i - 2)
            Range("J" + CStr(i)).Formula = "=复制!D" + CStr(i - 2)
            Range("L" + CStr(i)).Formula = "=复制!E" + CStr(i - 2)
            Range("N" + CStr(i)).Formula = "=复制!F" + CStr(i - 2)
            Range("P" + CStr(i)).Formula = "=复制!G" + CStr(i - 2)
            Range("R" + CStr(i)).Formula = "=IF(D" + CStr(i) + "<>0,(L" + CStr(i) + "+N" + CStr(i) + ")/P" + CStr(i) + ",0)"
            Range("U" + CStr(i)).Formula = "=IF(D" + CStr(i) + "<>0,复制!H" + CStr(i - 2) + ",NOW())"
            Range("V" + CStr(i)).Formula = "=IF(D" + CStr(i) + "<>0,复制!I" + CStr(i - 2) + ",NOW())"
            Range("W" + CStr(i)).Formula = "=IF(D" + CStr(i) + "<>0,复制!J" + CStr(i - 2) + ",NOW())"
            Range("X" + CStr(i)).Formula = "=IF(AND(V" + CStr(i) + ">=(W" + CStr(i) + "-61),F" + CStr(i) + "<>0),1,0)"
            
            '为参赛作品生成编号
            If Range("D" + CStr(i)) <> "tvb" And Range("D" + CStr(i)) <> "0" And Range("D" + CStr(i)) <> 0 Then
                Range("Y" + CStr(i)) = idno
                idno = idno + 1
            Else
                Range("Y" + CStr(i)) = 0
            End If
             
             '为新人作品生成编号
            If Range("X" + CStr(i)) = 1 And Range("D" + CStr(i)) <> "TVB" Then
                Range("Z" + CStr(i)) = idno_new
                idno_new = idno_new + 1
            Else
                Range("Z" + CStr(i)) = 0
            End If
        Next
    End If
    
        
    '前三名评奖程序
    If Target.Address = "$AD$1" Then
                
        ReDim winner(0)
        ReDim winner_row(0)
        '清空原有奖项
        Range("B3:B102") = ""
        Range("T3:T102") = ""
        Range("AA3:AA102") = ""
        Range("AB3:AB102") = ""
        
        '按是否新人、综合指数、发文时间降序排列
        Range("D3:Z102").Sort key1:=Range("X1"), order1:=2, key2:=Range("R1"), order2:=2, key3:=Range("U1"), order3:=2
        
        '前三名奖项名
        Static prize(3) As String
        prize(0) = "<b>一鸣惊人</b>奖"
        prize(1) = "<b>一字千钧</b>奖"
        prize(2) = "<b>一代风流</b>奖"
        
        
        '确认前三名
       
        i = 1
        j = 3
        Do While i <= 3
            If Range("D" + CStr(j)) <> "tvb" Then
                If i = 1 Then
                     Range("B" + CStr(j)) = prize(0)
                     Range("T" + CStr(j)) = i
                     ReDim Preserve winner(i)
                     ReDim Preserve winner_row(i)
                     winner(i - 1) = Range("D" + CStr(j))
                     winner_row(i - 1) = j
                     i = i + 1
                Else
                    If (chkrepeat(Range("D" + CStr(j)), winner)) = 0 Then
                        Range("B" + CStr(j)) = prize(i - 1)
                        Range("T" + CStr(j)) = i
                        ReDim Preserve winner(i)
                        ReDim Preserve winner_row(i)
                        winner(i - 1) = Range("D" + CStr(j))
                        winner_row(i - 1) = j
                        i = i + 1
                    End If
                End If
            End If
            j = j + 1
        Loop
    End If
    
    '幸运奖抽奖抽奖程序
    If Target.Address = "$AA$1" Then
        '清空原有奖项
        
        ReDim Preserve winner(3)
        ReDim Preserve winner(4)
        Range("AA3:AA102") = ""
        Range("AB3:AB102") = ""
        Range("B3:B102") = ""
        Range("T3:T102") = ""
        Dim tmparr(3) As String
        For i = 1 To 3
            Range("T" + CStr(winner_row(i - 1))) = i
            Range("B" + CStr(winner_row(i - 1))) = prize(i - 1)
            'tmparr(i - 1) = winner(i - 1)
        Next
        
        
        '抽取cnbuddy幸运点赞奖
        Dim lucky() As Integer                         '中奖作品行数
        ReDim Preserve winner(3)
        total_new_commer = Range("Z112")               '新人作品总数
        re = 1
        Do While re = 1
            rad = Round((total_new_commer - 3) * Rnd + 3.5) '+3是由于从编号第4的人开始抽奖，+0.5是为了保证四舍五入后的概率平均分配（以下同）
            author_row = row(rad, "Z3:Z102")
            tmp_author = Range("D" + CStr(author_row))
            
            If chkrepeat(tmp_author, winner) = 0 Then
                Range("AA" + CStr(3)) = tmp_author
                Range("AB" + CStr(3)) = Range("Y" + CStr(author_row))
                Range("T" + CStr(author_row)) = CStr(4)
                ReDim Preserve winner(4)
                ReDim Preserve lucky(1)
                winner(3) = tmp_author
                lucky(0) = author_row
                Range("B" + CStr(author_row)) = "@cnbuddy幸运点赞奖"
                re = 0
            End If
        Loop
        
        Total = Range("Y112") - 3                      '作品总数
        luck_total = Round(Range("Y112") / 10 + 0.01)  '幸运奖总数
        luck_name_total = Worksheets("奖项").Range("B1")
        
        
        i = 1
        Do While i <= luck_total
            rad = Round(Total * Rnd + 3.5)
            author_row = row(rad, "Y3:Y102")
            tmp_author = Range("D" + CStr(author_row))
            If chkrepeat(tmp_author, winner) = 0 Then  '中奖者不重复
                If i = 1 Then
                    Range("AA" + CStr(3 + i)) = tmp_author
                    Range("AB" + CStr(3 + i)) = rad
                    Range("T" + CStr(author_row)) = CStr(4 + i)
                    ReDim Preserve winner(4 + i)
                    winner(3 + i) = tmp_author
                    ReDim Preserve lucky(1 + i)
                    lucky(i) = author_row
                    luck_row = Round(luck_name_total * Rnd + 0.5)
                    Range("B" + CStr(author_row)) = "<b>" + Worksheets("奖项").Range("A" + CStr(luck_row)) + "</b>奖"
                    i = i + 1
                Else
                    If chkrepeat(rad, lucky) = 0 Then
                        Range("AA" + CStr(3 + i)) = tmp_author
                        Range("AB" + CStr(3 + i)) = rad
                        Range("T" + CStr(author_row)) = CStr(4 + i)
                        ReDim Preserve winner(4 + i)
                        winner(3 + i) = tmp_author
                        ReDim Preserve lucky(1 + i)
                        lucky(i) = author_row
                        luck_row = Round(luck_name_total * Rnd + 0.5)
                        Range("B" + CStr(author_row)) = "<b>" + Worksheets("奖项").Range("A" + CStr(luck_row)) + "</b>奖"
                    i = i + 1
                    End If
                End If
            End If
        Loop
        Range("b3:Z102").Sort key1:=Range("T1"), order1:=1
    End If
End Sub

讲着累，大家看代码吧。

另外还有两个函数：

'获取行数的函数
Public Function row(value, area)
    For Each Rng In Range(area)
        If (Rng = value) Then
            row = Rng.row
        End If
    Next
End Function

'查询某值是否在某数组中（检查是否重复）
Public Function chkrepeat(value, arr)
    chkrepeat = 0
    For Each a In arr
        If a = value Then
            chkrepeat = 1
            Exit For
        End If
    Next
End Function

文件在github上：

https://github.com/wozhuibenle/excel-prize-draw

先运行“初始化”、再运行评奖，最后运行抽取幸运奖，过程如下：