VBA Rnd でイベントを盛り上げる！公平なランダム抽選機能を実装する方法

忘年会、社内イベント、キャンペーン、新年の運試し…イベントを企画する際に頭を悩ませるのが「抽選」ではないでしょうか？ 手作業での抽選は手間がかかるだけでなく、公平性に疑問符がつきかねません。 「もっとスマートに、そして誰が見ても納得できる公平な抽選を行いたい！」 VBAエキスパートの皆さん、そんな悩みをVBAのRnd関数が解決します。 この記事では、VBAを使って、コピペで即座に動く実用的なランダム抽選機能のコードと、落とし穴を回避する重要なテクニックをご紹介します。

実務で使える！重複なしランダム抽選VBAコード

以下のコードは、指定したシートのA列に参加者リストがあることを想定し、そこから指定された人数を重複なくランダムに抽選し、「抽選結果」という新しいシートに表示します。 コード内のコメントに従って、シート名や範囲を適宜調整してご活用ください。

Sub FairLotterySystem()
    ' --- 重要: 常に異なる乱数系列を生成するために必須 ---
    Randomize

    ' 1. 設定部分: 参加者リストのあるシートと範囲を指定
    Dim wsParticipants As Worksheet
    Set wsParticipants = ThisWorkbook.Sheets("参加者リスト") ' <-- ここに実際のシート名を記入してください

    Dim firstRow As Long
    firstRow = 2 ' 参加者リストが始まる行 (例: 1行目がヘッダーなら2)
    Dim participantColumn As Long
    participantColumn = 1 ' 参加者名が入力されている列 (例: A列なら1)

    Dim lastRow As Long
    ' 参加者名列の最終行を自動取得
    lastRow = wsParticipants.Cells(Rows.Count, participantColumn).End(xlUp).Row

    ' 参加者リストの範囲を決定
    Dim participantRange As Range
    Set participantRange = wsParticipants.Range(wsParticipants.Cells(firstRow, participantColumn), wsParticipants.Cells(lastRow, participantColumn))

    If participantRange.Rows.Count < 1 Then
        MsgBox "抽選対象の参加者がいません。シート名と範囲を確認してください。", vbExclamation
        Exit Sub
    End If

    ' 2. 当選者数の入力
    Dim numWinners As Long
    On Error Resume Next ' エラー発生時（キャンセルなど）に備える
    numWinners = Application.InputBox( _
        Prompt:="何名を抽選しますか？ (現在の参加者数: " & participantRange.Rows.Count & ")", _
        Title:="当選者数入力", _
        Default:=1, _
        Type:=1 ' 数値入力のみ許可
    )
    On Error GoTo 0 ' エラーハンドリングを解除

    If numWinners = 0 Then ' InputBoxでキャンセルされた場合
        MsgBox "抽選をキャンセルしました。", vbInformation
        Exit Sub
    End If

    If numWinners < 1 Or numWinners > participantRange.Rows.Count Then
        MsgBox "当選者数は1以上、かつ参加者数以下で指定してください。", vbExclamation
        Exit Sub
    End If

    ' 3. 参加者リストを配列に読み込み
    Dim participants() As String
    ReDim participants(1 To participantRange.Rows.Count)
    Dim i As Long
    For i = 1 To participantRange.Rows.Count
        participants(i) = participantRange.Cells(i, 1).Value
    Next i

    ' 4. Fisher-Yatesシャッフルアルゴリズムで配列をシャッフル (重複なし抽選の実現)
    Dim j As Long
    Dim temp As String
    For i = UBound(participants) To LBound(participants) Step -1
        ' LBoundからiまでの乱数を生成し、要素をスワップ
        ' これにより、後で先頭からnumWinners分取得するだけで重複なしのランダム選択が可能
        j = Int((i - LBound(participants) + 1) * Rnd + LBound(participants))
        temp = participants(i)
        participants(i) = participants(j)
        participants(j) = temp
    Next i

    ' 5. 抽選結果シートの準備と表示
    Dim wsResult As Worksheet
    On Error Resume Next ' 既存シートがあるかチェック
    Set wsResult = ThisWorkbook.Sheets("抽選結果")
    On Error GoTo 0

    If wsResult Is Nothing Then
        ' なければ新しいシートを作成
        Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsResult.Name = "抽選結果"
    Else
        ' 既存のシートがある場合は内容をクリア
        wsResult.Cells.ClearContents
    End If

    ' ヘッダーの書き込み
    wsResult.Cells(1, 1).Value = "当選者"
    wsResult.Cells(1, 2).Value = "抽選日時"
    wsResult.Cells(2, 2).Value = Now

    ' 当選者をシートに書き出し
    For i = 1 To numWinners
        wsResult.Cells(i + 1, 1).Value = participants(i)
    Next i

    ' 抽選結果シートを見せる
    wsResult.Activate
    wsResult.Cells(1, 1).CurrentRegion.Columns.AutoFit

    MsgBox numWinners & "名の抽選が完了しました！ '抽選結果'シートをご確認ください。", vbInformation

End Sub
    

【重要】「毎回同じ乱数」の落とし穴回避！Randomizeステートメントの威力

VBAでRnd関数を使って乱数を生成する際、多くの人が一度は経験する「落とし穴」があります。 それは、マクロを起動するたびに、毎回同じ順番で乱数が出てしまうという現象です。 これでは公平な抽選とは言えませんよね。

Randomizeステートメントは、システムのタイマーを乱数ジェネレーターのシード（種）として使用します。 これにより、マクロを実行するたびに異なる初期シード値が設定され、結果として予測不可能な乱数列が生成されるようになります。 上記のコードの冒頭にRandomizeを記述しているのは、この「落とし穴」を回避し、真にランダムで公平な抽選を実現するためです。 この一行を忘れないようにしましょう。

まとめ

VBAのRnd関数と、その真の力を引き出すRandomizeステートメントを組み合わせることで、 あなたはイベント運営における強力なツールを手に入れることができます。 公平で、手間いらず、そしてプロフェッショナルなランダム抽選機能を実装し、 イベントをさらに盛り上げてください。 今回ご紹介したコードは、実務でよくある「重複なし抽選」にも対応しており、 少し手を加えるだけで様々なイベントに適用可能です。 ぜひ、あなたのVBAスキルをイベント運営にも役立ててみてください！