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

in #cn • 6 years ago (edited)

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

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

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

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

制作第三个按钮单元格，点击以后，计算幸运奖名额，然后，随机生成数，乘以参与抽奖的文章总数，然后加上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

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

121.gif

#cn-programming #cn-31 #cn-voice #cn-funny
6 years ago in #cn by
$4.54
  • Past Payouts $4.54, 0.00 TRX
  • - Author $3.67, 0.00 TRX
  • - Curators $0.87, 0.00 TRX
32 votes
Reply 15
Sort:  
  • Trending
    • [-]
     6 years ago 

    @tvb, 得到朕的雨露均沾的...你的声音会更优美...

    $0.00
      Reply
      [-]
       6 years ago 

      @tvb, 这是小可可我在steemit最好的邂逅，好喜欢你的声音（＾∀＾）哇~~~ img

      BTW, @cn-naughty.boy 淘气包你讨厌，抢伦家沙发~哼~~~ (>_<、)

      $0.00
        Reply
        [-]
         6 years ago 

        一姐，这个代码到时我可能会用到，谢谢你的分享～

        $0.00
          Reply
          [-]
           6 years ago 

          好像要设置一下才能用，等我编辑一下。

          $0.00
            Reply
            [-]
             6 years ago (edited)

            To do or not to do? That is the question.:-)

            $0.00
              Reply
              [-]
               6 years ago 

              英语不好呀哥。。。。

              $0.00
                Reply
                [-]
                 6 years ago 

                沒什麽。只是因兔字押韻一下。:-)

                $0.00
                  Reply
                  [-]
                   6 years ago 

                  我明白了，我发了这么多，假如幸运奖抽不到我，我得多不幸😂

                  $0.00
                    Reply
                    [-]
                     6 years ago 

                    你不是第三名嘛，我特意看的，别人我都不看直接复制的哈哈。我觉得要再调调综合评分的计算方法了，现在有点偏向新人哈哈

                    $0.00
                      Reply
                      [-]
                       6 years ago 

                      哦，看不懂的excel系列。

                      我就只会用RANK和INDEX搞点简单小抽奖。

                      $0.00
                        Reply
                        [-]
                         6 years ago 

                        这也是随机函数呀，但因为要考虑重复的问题，比如有3个幸运奖，不能抽到重复的编号。再就是有的人一稿多投，抽到的概率确实是高，但只能得一次奖，如果重复了就要重新抽。就这点事。
                        而且前三名也是用的程序，我就不用自己数了嘛。

                        $0.00
                          Reply
                          [-]
                           6 years ago 

                          收藏了，谢谢@tvb姐分享，完全不懂代码，需要的时候直接复制粘贴运行，哈哈...

                          $0.00
                            Reply
                            [-]
                             6 years ago 

                            excel代码这一块我都不会用……
                            看来得好好进修一下……

                            $0.00
                              Reply
                              [-]
                               6 years ago 

                              一姐，你也太厉害了吧，哈哈

                              $0.00
                                Reply

                                Coin Marketplace

                                STEEM 0.30
                                TRX 0.12
                                JST 0.033
                                BTC 63332.97
                                ETH 3169.28
                                USDT 1.00
                                SBD 3.89