マンゴー抽選にチャレンジ

フォロワーさんがこのようなものにチャレンジしているのを見かけた。

koroko.hatenablog.com

自分はあまりこういう演出系の処理をしたことがないのでチャレンジしてみた。

コード

例のごとく早速コード

Option Explicit

Sub マンゴー抽選()
     Dim MangoNum As Long
     Dim UserNum As Long
     Dim myArray As Variant
     
     '抽選参加数
     UserNum = Worksheets("sheet1").Range("A5:A" & Rows.Count).SpecialCells(xlCellTypeConstants).Count
     
     ReDim myArray(UserNum - 1)
     Dim i As Long
     
     '数値の上位者を当選とする。ここで参加者数の配列を用意し乱数で数値を割り振る
     For i = 0 To UserNum - 1
          myArray(i) = Rnd()
     Next i
     
     '当選者数
     MangoNum = Worksheets("sheet1").Range("B2").Value
     
     
     '当選者数に達していない場合は演出処理を実行。当選者数に達している場合は即判定。
     Dim n As Long
     For i = 0 To UserNum - 1
          If n < MangoNum Then AnsRoll (i)
          If myArray(i) >= Application.WorksheetFunction.Large(myArray, MangoNum) Then
               Cells(i + 5, 2).Value = "当たり"
               n = n + 1
          Else
               Cells(i + 5, 2).Value = "はずれ"
          End If
     Next i
End Sub
'---------------------------------------
'演出処理
Sub AnsRoll(AnsNum As Long)
     Dim i As Long
     
     For i = 1 To 1000
          Select Case i Mod 4
               Case 0
                    Cells(AnsNum + 5, 2).Value = "当たり"
               Case 1
                    Cells(AnsNum + 5, 2).Value = "はずれ"
               Case 2
                    Cells(AnsNum + 5, 2).Value = "当選"
               Case 3
                    Cells(AnsNum + 5, 2).Value = "スカ"
          End Select
          i = i + 1
     Next i
End Sub

完成品

昔の電車の行き先案内のようなパタパタを表現したつもりです。

まとめ

こういうのってちゃんと動くというだけでなく、デザインというか演出のセンスがいるから難しいですね。