Excelで抽選システムをつくる

概要

Twitterでプレゼント企画をするにあたり、公正な抽選がしたかったので、抽選システムを作ることにしました。また、特定の人の当選確率をアップさせる機能も実装しています。

コメントもたくさん入れて書いたので、VBAほとんどつついたことない！って人でも、一つ一つ見れば理解できると思います。

【 sheet1（"候補者"と名前定義）の画像 】

一部個人情報保護のために編集しています。
セルに対して名前定義は行っていません。

【 sheet2（"抽選"と名前定義）の画像 】

一部個人情報保護のために編集しています。
名前定義は画像に示した通り行っています。

実際に動かすとこんな感じです。↓

途中、カウンターが飛んでいるように見えるのが、確率アップしている証拠です。
動画のように、確率アップの候補者が当選すると、カウンターはマイナスで終了します。

では、実際に動作確認済みのVBAコードを見てみましょう。

コード

動作確認バージョン: Microsoft Office 365, Windows10 64bit

Sub 抽選()
    '見出しが「確率アップ！」の列数を変数に格納
    Dim 確率アップ列 As Integer: 確率アップ列 = Sheets("候補者").Rows(1).Find("当選確率アップ！", , xlValues, xlWhole).Column
    '見出しが「候補者」の列数を変数に格納
    Dim 候補者列 As Integer: 候補者列 = Sheets("候補者").Rows(1).Find("候補者", , xlValues, xlWhole).Column
    '200から400までの範囲で乱数を生成
    '(ここは候補者の数によって調整しないと、上の方に名前がある人が当たりやすくなります。)
    '(ランダム性をあげるなら、候補者をランダムに並び替えると有効だと思います。)
    Dim random As Integer: random = (400 - 200 + 1) * Rnd + 200
    Dim i As Integer: i = 0
    Dim Row As Integer: Row = 2
    Dim 当選確率アップ As Integer
    '候補者列の最下行数を変数に格納
    Dim 一番下の行数 As Integer: 一番下の行数 = WorksheetFunction.CountIf(Sheets("候補者").Range("候補者列"), "<>")
    
     'カウンターが0より大きい間、抽選を続ける
     Do While i < random

         If random - i > 200 Then
            'Application.Wait [Now()] + N / 86400000 とすることで、Nミリ秒間スリープできるらしい
            Application.Wait [Now()] + 5 / 86400000
         ElseIf random - i > 100 Then
            Application.Wait [Now()] + 10 / 86400000
         ElseIf random - i > 30 Then
            Application.Wait [Now()] + 50 / 86400000
         ElseIf random - i > 10 Then
            Application.Wait [Now()] + 150 / 86400000
         ElseIf random - i > 3 Then
            Application.Wait [Now()] + 300 / 86400000
         ElseIf random - i > 1 Then
            Application.Wait [Now()] + 500 / 86400000
         Else
            Application.Wait [Now()] + 800 / 86400000
         End If
         
          '当選確率が空欄なら、カウンターを1進め、NならN進める
          If Sheets("候補者").Cells(Row, 確率アップ列) = "" Then
            当選確率アップ = 1
          Else
            当選確率アップ = Sheets("候補者").Cells(Row, 確率アップ列)
          End If
          
          i = i + 当選確率アップ
        
　　　　'一番下まで来たら上に戻る
        If Row < 一番下の行数 Then
          Row = Row + 1
        Else
          Row = 2
        End If
          
        Sheets("抽選").カウンター.Caption = random - i
        Sheets("抽選").名前表示ラベル.Caption = Sheets("候補者").Cells(Row, 候補者列)
        'よくわからないけど、DoEventをたくさん書くと画面描画が安定する
        DoEvents
        DoEvents
        DoEvents
        DoEvents
        DoEvents
     Loop
      Sheets("抽選").ご当選おめでとうラベル.Caption = "ご当選おめでとうございます !!!"
 End Sub

Sub リセット()
    Sheets("抽選").ご当選おめでとうラベル.Caption = ""
    Sheets("抽選").名前表示ラベル.Caption = ""
    Sheets("抽選").カウンター.Caption = ""
End Sub

所感

このVBAで一番苦労したのは、名前表示ラベルとカウンターの画面描画についてです。
僕の環境では、DoEvents無しの状態だと名前表示ラベルは正常に表示されませんでした。
その後、いろんなタイミングでDoEventsを差し込んでみたものの、名前表示やカウンターの値が飛んで表示され、半分諦めていました。
そこで、ダメもとでDoEventsを複数連ねてみると、なぜか正常に動きました。
VBAってほんと...