抽籤マクロ(Excel)
順番の抽籤をする
研修会とかそういう機会に、発表の順序を決めるとき。
自薦方式をとったり、じゃんけんで決めてもらったりするのも良いが、Excelでやってみてもいいんではないか、と思った。
準備
次のようなシートを準備。
「抽籤!」ボタンをクリックすると、セルに発表グループ名(今回は番号)が表示されるようにする。
仕様
ただ発表順がいっぺんに表示されるだけだと盛り上がらないので(別に盛り上げる必要はないんだが。)、
- 正式表示まで番号がグルグル表示されるようにする
- 一つづつ、それなりに間を空けて表示されるようにする
- 終わったら「決定!」と表示するようにする
と、こんな感じにした。
抽籤マクロのコード
シートモジュールにメインのコードを書くことにし、乱数発生のためのモジュール(自作のRandUtil
モジュール)と、WindowsAPI関数呼び出し用のクラス(自作のWinAPI
クラス)をインポートして使用した。
リスト1 標準モジュールRandUtil
Option Explicit Public Function getRandomOrder( _ ByVal maxNumber As Long, _ Optional ByVal allowDuplicate As Boolean = False) As Long() '///1~maxNumまでの整数をランダムに並べて配列に格納する。' '///引数maxNum:最大数' '///引数allowDuplicate:重複を許可するならTrue' Dim ret() As Long Dim hasSet() As Boolean ReDim hasSet(maxNumber - 1) Dim i As Long ReDim ret(maxNumber - 1) Randomize Dim tmp As Long For i = 0 To maxNumber - 1 Do tmp = Int(maxNumber * Rnd + 1) '///乱数:Int((最大値 - 最小値 + 1) * Rnd + 最小値)' Loop Until hasSet(tmp - 1) = False ret(i) = tmp If Not allowDuplicate Then hasSet(tmp - 1) = True Next getRandomOrder = ret End Function
リスト2 クラスモジュールWindowsAPI
※必要な部分のみ。
Option Explicit '///Attribute VB_PredeclaredId = True////' 'WindowsAPI Functions' Private Declare Function GetTickCount Lib "kernel32" () As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'Methods' Public Function callGetTickCount() As Long Dim ret As Variant ret = GetTickCount() ret = CDec(ret) If ret < 0 Then ret = ret + 2 ^ 32 callGetTickCount = ret End Function Public Sub callSleep(ByVal milliSeconds As Long) Call Sleep(milliSeconds) End Sub Public Sub waitFor(ByVal milliSeconds As Long) Dim startTime As Long startTime = callGetTickCount() Dim endTime As Long Do Call Sleep(1) DoEvents endTime = callGetTickCount() Loop Until endTime - startTime > milliSeconds End Sub
リスト3 シートモジュールSh01Main
Option Explicit Private Const AREA_ADDRESS As String = "$A$2:$F$2" Private Enum Sh01ErrorCode sh01ecUnknown sh01ecIncorrectArg End Enum Public Property Get DisplayArea( _ Optional ByVal indexOf As Long) As Range Const ERR_SOURCE As String = _ "Sh01Main Property Get DisplayArea" '引数indexOfを省略したら範囲全体を返す' Dim ret As Range Set ret = Me.Range(AREA_ADDRESS) If indexOf = 0 Then GoTo Finalizer 'ガード節:不正引数を弾く' If indexOf > ret.Columns.Count Then _ Call raiseError(sh01ecIncorrectArg, ERR_SOURCE) '引数indexOfに応じたセルを返す' Set ret = ret.Cells(1, indexOf) Finalizer: Set DisplayArea = ret End Property Private Sub setNumber() 'グルグル表示のリピート回数' Const REPEAT_COUNT As Long = 8 'グルグル表示のインターバル' Const DISPLAY_INTERVAL As Long = 50 '抽選結果表示のインターバル' Const SHOW_INTERVAL As Long = 1000 Dim targetArea As Range Set targetArea = Me.DisplayArea '一旦表示をクリア' Call targetArea.ClearContents Dim maxNumber As Long maxNumber = targetArea.Columns.Count - 1 '乱数配列を取得' Dim order() As Long order = RandUtil.getRandomOrder(maxNumber, False) 'WinAPIクラスをインスタンス化' Set winAPI = New WindowsAPI Dim i As Long Dim j As Long For i = LBound(order) To UBound(order) With Me.DisplayArea(i + 1) 'グルグル表示' For j = 0 To (maxNumber * REPEAT_COUNT) - 1 '0.1秒ごとに数字を表示' .Value = order(j Mod maxNumber) Call winAPI.waitFor(DISPLAY_INTERVAL) Next '結果表示' .Value = order(i) '少し間を空ける' Call winAPI.waitFor(SHOW_INTERVAL) End With Next '「決定!」表示' Me.DisplayArea(maxNumber + 1).Value = "決定!" End Sub Private Sub raiseError(ByVal errCode As Sh01ErrorCode, _ ByVal errSource As String) Dim msg As String Select Case errCode Case sh01ecIncorrectArg ret = "The arg ""indexOf"" is out of bound." Case Else ret = "Some error has occurred!" End Select Call Err.Raise(Number:=10000 + errCode, _ Source:=errSource, _ Description:=ret) End Sub
例によって、現時点では特に必要でもないエラー対応なんかを入れたせいでタテ長になっている。
必要な箇所にはコメントを入れているので、細かい説明は省略。
実行
シート上のコマンドボタンにSh01Main
モジュールのsetNumber
メソッドを登録して実行。
ご覧のとおり。
おわりに
身内向けの研修会なんかだと、この程度のギミックを披露するだけで歓声が上がるのだから、チョロいもんですw(実際、今回のギミックは、昼休みの10分ぐらいでサクッと作ったもの。)
WindowsAPI関数をもっとふんだんに使用して、グルグル表示中にドラムロールを鳴らしたりしたら、もっとウケるだろうな……。当面やるつもりはないけど。
あと、美しさを求めるなら、ユーザーフォームでしょうね。
参考
コチラもどうぞ!