和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > VBA問題集 > Excelで作るルーレット - ExcelFun記念イベント

Excelで作るルーレット - ExcelFun記念イベント

VBA問題集 イベント・勉強会 VBA

Excel・VBA総合コミュニティ「Excel-Fun.xls*」にて、
参加者1,000名突破記念イベントを先日開催いたしました。

1000名突破記念イベント画像

ご参加いただいている皆様、いつも本当にありがとうございます！


この記念イベントでは日頃の感謝の気持ちを込めて、
ささやかなプレゼント企画を実施いたしました。

そしてその抽選には、
ExcelのコミュニティらしくExcelを使った抽選ツールを使おう！
ということで、私和風スパゲティより作成させていただきました。


作成したルーレットがこちらです！

ルーレットアニメ


このファイルとソースコードを共有いたしますので、
よろしければご参考ください。

Excelファイル

(和風スパ)【Excel】003_Excelルーレット.xlsm
当選画像

※ コード内で歓声を鳴らすMP3ファイルを再生しています。
その音声ファイルは「効果音ラボ」様のコンテンツを利用させていただきました。
こちらのリンクよりダウンロードしてご使用ください。
soundeffect-lab.info

ソースコード

モジュール構成

Pr_ルーレット

Option Explicit

Const Adrs第1センターセル = "C5"
Const Adrs対象者リスト第1セル = "D2"
Const R_第1センターセル = 5
Const CAdrsルーレット列 = "C"
Private Arr参加者リスト

' 初期化
Sub ★ルーレットの初期化()

    WSルーレット.Activate

    ' 書式と値をクリア
    Cells.EntireRow.Hidden = False
    Columns(CAdrsルーレット列).Interior.ColorIndex = 0
    Intersect(Columns(CAdrsルーレット列), ActiveSheet.UsedRange).Value = ""
    
    ' 参加者リストの配列を取得
    If WS対象者.Range(Adrs対象者リスト第1セル).Value = "" Then
        MsgBox "対象者リストを入力して下さい。"
        WS対象者.Activate
        Exit Sub
    End If
    Call 対象者をシャッフルする
    Arr参加者リスト = Rangeから1次元配列を生成(GetRangeCtrlShift↓(WS対象者.Range(Adrs対象者リスト第1セル)))

    ' 最初の5名を出力
    If Count配列の要素数(Arr参加者リスト) < 5 Then
        MsgBox "対象者は5名以上必要です"
        Exit Sub
    End If
    Dim i As Long
    For i = 0 To 4
        Range(Adrs第1センターセル).Offset(-2 + i) = Arr参加者リスト(i)
    Next

    ' ルーレット内の生成
    Call ルーレット内を装飾する(Range(Adrs第1センターセル))

    ' 紙吹雪のGif画像を画面外へ移動
    ActiveSheet.Shapes("紙吹雪").Top = Range("AA1").Top
    ActiveSheet.Shapes("紙吹雪").Left = Range("AA1").Left

    ' 第1センターセルを表示
    Range(Adrs第1センターセル).Select

End Sub

' ルーレットのスタート
Sub ★ルーレットを開始する()
    
    If IsEmpty(Arr参加者リスト) Then
        MsgBox "リセットしてから実行してください。"
        Exit Sub
    End If
    
    ' 第1センターセルを表示
    Range(Adrs第1センターセル).Select

    ' 全員が当確率になるよう参加者数をRANDBETWEEENの上限に
    Dim 参加者数 As Long
    参加者数 = Count配列の要素数(Arr参加者リスト)

    ' ルーレットのアニメーション
    Call ルーレットを回転する(4, 0, 0.15)
    Call ルーレットを回転する(5, 0, 0.1)
    Call ルーレットを回転する(8, 0, 0.07)
    Call ルーレットを回転する(16, 0, 0.05)
    Call ルーレットを回転する(100, 参加者数 - 1, 0.01)
    Call ルーレットを回転する(16, 0, 0.05)
    Call ルーレットを回転する(8, 0, 0.1)
    Call ルーレットを回転する(4, 0, 0.2)
    Call ルーレットを回転する(3, 0, 0.3)
    Call ルーレットを回転する(2, 0, 0.4)
    Call ルーレットを回転する(1, 0, 0.5)
    Call ルーレットを回転する(1, 0, 0.6)
    Call ルーレットを回転する(1, 0, 0)
    
    ' 背景色を当選色に
    ActiveCell.Interior.Color = RGB(226, 194, 0)
    
    ' 紙吹雪のGIF画像を移動して表示
    ActiveSheet.Shapes("紙吹雪").Top = Range("A1").Top
    ActiveSheet.Shapes("紙吹雪").Left = Range("A1").Left
    
    ' 歓声のMP3ファイルを再生（ファイルパスは書き替えて使ってください）
    MP3を再生する "C:\Users\wfsp\Desktop\1000人記念イベント\歓声と拍手1.mp3"
    
    ' 参加者の更新前に次が回らないよう参加者リストの配列を初期化
    Arr参加者リスト = Empty
    
End Sub

' ルーレットの回転
Sub ルーレットを回転する(基本回転数 As Long, 乱数上限 As Long, ロールごとの描画時間 As Double)

    Dim i As Long
    For i = 1 To 基本回転数 + WorksheetFunction.RandBetween(0, 乱数上限)
        
        ActiveCell.Offset(-2).EntireRow.Hidden = True
        ActiveCell.Offset(1).Select
        ActiveCell.Offset(2).Value = Arr参加者リスト((ActiveCell.Row - R_第1センターセル + 4) Mod Count配列の要素数(Arr参加者リスト))
        Call ルーレット内を装飾する(ActiveCell)
        Call s秒待機する(ロールごとの描画時間)
    Next

End Sub

' ルーレット内の装飾
Sub ルーレット内を装飾する(センターセル As Range)
    
    ' 背景色
    センターセル.Offset(-2).Interior.Color = RGB灰色(200)
    センターセル.Offset(-1).Interior.Color = RGB灰色(220)
    センターセル.Offset(0).Interior.Color = RGB灰色(240)
    センターセル.Offset(1).Interior.Color = RGB灰色(220)
    センターセル.Offset(2).Interior.Color = RGB灰色(200)
    
    ' フォント
    センターセル.Offset(-2).Font.Color = RGB灰色(150)
    センターセル.Offset(-1).Font.Color = RGB灰色(150)
    センターセル.Offset(0).Font.Color = RGB灰色(0)
    センターセル.Offset(1).Font.Color = RGB灰色(150)
    センターセル.Offset(2).Font.Color = RGB灰色(150)

End Sub

' 対象者のシャッフル
Sub 対象者をシャッフルする()
    WS対象者.ListObjects(1).ListColumns(2).DataBodyRange.Formula = "=RAND()"
    WS対象者.ListObjects(1).ListColumns(2).DataBodyRange.Value _
        = WS対象者.ListObjects(1).ListColumns(2).DataBodyRange.Value
End Sub

Ut_汎用関数

Option Explicit

Function Count配列の要素数(Arr, Optional 次元 = 1) As Long
    Count配列の要素数 = UBound(Arr, 次元) - LBound(Arr, 次元) + 1
End Function

Function Rangeから1次元配列を生成(対象Range As Range) As Variant

    Dim Arr生成配列() As Variant
    ReDim Arr生成配列(対象Range.Cells.Count - 1) As Variant
    
    Dim i As Long: i = 0
    Dim cell As Range
    For Each cell In 対象Range.Cells
        Arr生成配列(i) = cell.Value
        i = i + 1
    Next

    Rangeから1次元配列を生成 = Arr生成配列
End Function

Function GetRangeCtrlShift↓(始点セル As Range) As Range

    If 始点セル.Value = "" Or 始点セル.Offset(1).Value = "" Then
        Set GetRangeCtrlShift↓ = 始点セル
    Else
        Set GetRangeCtrlShift↓ = Range(始点セル, 始点セル.End(xlDown))
    End If

End Function

Sub s秒待機する(s As Double)
    Application.Wait [Now()] + s / 86400
End Sub

Function RGB灰色(各RGB値 As Long) As Long
    RGB灰色 = RGB(各RGB値, 各RGB値, 各RGB値)
End Function

Pr_MP3再生

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function MCI文字列送信 Lib "winmm.dll" Alias "mciSendStringA" _
        (ByVal コマンド文字列 As String, ByVal 戻り値文字列 As String, _
         ByVal 戻り値長さ As Long, ByVal コールバックハンドル As LongPtr) As Long
#Else
    Private Declare Function MCI文字列送信 Lib "winmm.dll" Alias "mciSendStringA" _
        (ByVal コマンド文字列 As String, ByVal 戻り値文字列 As String, _
         ByVal 戻り値長さ As Long, ByVal コールバックハンドル As Long) As Long
#End If

Private Const MP3別名 As String = "ＭｙＭＰ３"

' ファイルを再生
Public Sub MP3を再生する(ByVal ファイルパス As String)
    Dim コマンド As String
    Dim 戻り値 As Long

    ' 既に同名の alias が開かれていれば閉じる（安全策）
    コマンド = "close " & MP3別名
    On Error Resume Next
    戻り値 = MCI文字列送信(コマンド, vbNullString, 0, 0)
    On Error GoTo 0

    ' ファイルパスに空白や日本語が含まれるので二重引用符で囲む
    コマンド = "open """ & ファイルパス & """ type mpegvideo alias " & MP3別名
    戻り値 = MCI文字列送信(コマンド, vbNullString, 0, 0)
    If 戻り値 <> 0 Then
        MsgBox "ファイルを開けませんでした。パスを確認してください：" & vbCrLf & ファイルパス, vbExclamation
        Exit Sub
    End If

    ' 再生（非同期）
    コマンド = "play " & MP3別名
    戻り値 = MCI文字列送信(コマンド, vbNullString, 0, 0)
    If 戻り値 <> 0 Then
        MsgBox "再生に失敗しました。", vbExclamation
    End If
End Sub

解説

今回はイベントまでの時間もなかったため、
「コーディング・実装が簡単な方法」
をテーマに作成しました。

意外と構造は簡単で、

  • ルーレットの外装は背景で設定
    （背景は表示セルに関わらず位置固定）
  • ルーレットが回るごとに一番上の行を非表示にしてリールを再現

という設計になっています。


Excelのスクロールは何となく回っているように描画されるため、
セルの値を切り替えるよりは回った感がでそうというのが狙いです。


ルーレットが低速 ⇒ 高速 ⇒ 低速 ⇒ 停止と回ったように見せるために、

' ルーレットのアニメーション
Call ルーレットを回転する(4, 0, 0.15)
Call ルーレットを回転する(5, 0, 0.1)
Call ルーレットを回転する(8, 0, 0.07)
Call ルーレットを回転する(16, 0, 0.05)
Call ルーレットを回転する(100, 参加者数 - 1, 0.01)
Call ルーレットを回転する(16, 0, 0.05)
Call ルーレットを回転する(8, 0, 0.1)
Call ルーレットを回転する(4, 0, 0.2)
Call ルーレットを回転する(3, 0, 0.3)
Call ルーレットを回転する(2, 0, 0.4)
Call ルーレットを回転する(1, 0, 0.5)
Call ルーレットを回転する(1, 0, 0.6)
Call ルーレットを回転する(1, 0, 0)

このように、回転数と回転速度を指定できるSubプロシージャを作り、
あとは頑張っていい感じになるよう微調整しました。


この手のツールは完成後にデザインの微調整で何度もパラメータをいじるため、
パラメータのいじりやすさも重要なファクターになると思います。


灰色系のRGB値（RとGとBが同値）の微調整において、

Function RGB灰色(各RGB値 As Long) As Long
    RGB灰色 = RGB(各RGB値, 各RGB値, 各RGB値)
End Function

こんなFunctionを作ったのも、
同じ数値を3連打せずに済み、ルーレットの微調整に役立ちました。


デザインが重要なマクロを作成するときは、
パラメータのいじりやすさも意識して設計してみてください。


なお、MP3の再生関数はChatGPTさんに丸投げしました。


今回の「MP3ファイルのファイルパスを渡したら音声が再生される」
のようなAIが誤解しようのない仕様のコードは、
AIさんに作ってもらうのがうってつけですね。