【ExcelVBA・マクロ】重複しない乱数を生成する方法|抽選・くじ引きシステムに使えるVBAコード【コピペOK】

ExcelVBA

くじ引きや抽選ツールをVBAで作ろうとすると、単純にRnd関数で乱数を生成するだけでは同じ番号が複数回出てしまい、当選者が重複するといった問題が起こります。この記事では、重複のない乱数を生成する2つの方法(Dictionaryによる重複チェック方式、配列シャッフル方式)を、実際にくじ引きシステムへ応用する例とあわせて解説します。

スポンサーリンク
スポンサーリンク

Rnd関数だけでは重複を防げない

まず前提として、VBAのRnd関数はあくまで「0以上1未満のランダムな数値」を返すだけで、それを使って複数回乱数を生成しても、同じ値が出ないという保証はありません。

Sub GenerateRandomNumbers_NG()

    Dim i As Long

    Randomize

    For i = 1 To 5
        Debug.Print Int(30 * Rnd) + 1  ' 1〜30の乱数(重複する可能性あり)
    Next i

End Sub

このコードを実行すると、5回とも異なる値が出ることもあれば、たまたま同じ値が複数回出ることもあります。くじ引きのように「1人に1つの番号」を割り当てたい場面では、これでは困ります。そこで、重複を防ぐ仕組みが必要になります。

方法1:Dictionaryで重複チェックしながら生成する

もっとも直感的な方法は、生成した乱数をDictionaryに記録しておき、すでに出た値であれば生成し直すというやり方です。

Sub GenerateUniqueRandomNumbers_Dictionary()

    Const COUNT As Long = 10        ' 生成する個数
    Const MIN_VALUE As Long = 1     ' 最小値
    Const MAX_VALUE As Long = 30    ' 最大値

    Dim dict As Object
    Dim randNum As Long
    Dim key As Variant
    Dim resultText As String

    Set dict = CreateObject("Scripting.Dictionary")

    Randomize

    Do While dict.Count < COUNT
        randNum = Int((MAX_VALUE - MIN_VALUE + 1) * Rnd) + MIN_VALUE
        If Not dict.Exists(randNum) Then
            dict.Add randNum, randNum
        End If
    Loop

    For Each key In dict.Keys
        resultText = resultText & key & " "
    Next key

    MsgBox resultText

    Set dict = Nothing

End Sub

dict.Exists(randNum)で「その値がすでに記録済みかどうか」を判定し、未記録の場合だけdict.Addで追加します。Do While dict.Count < COUNTにより、必要な個数がそろうまでこの処理を繰り返します。コードが直感的で分かりやすい一方、生成する個数が範囲の上限に近づくほど「すでに出た値」を引き当てる確率が上がり、処理に時間がかかる点には注意が必要です。

方法2:配列をシャッフルして先頭から取り出す

範囲全体に近い個数の乱数が必要な場合は、あらかじめ範囲内の数値をすべて配列に入れておき、その配列をランダムな順序に並び替えてから必要な個数だけ取り出す方法が効率的です。この並び替えには「Fisher-Yatesシャッフル」と呼ばれる定番のアルゴリズムを使います。

Sub GenerateUniqueRandomNumbers_Shuffle()

    Const COUNT As Long = 10        ' 取り出す個数
    Const MIN_VALUE As Long = 1     ' 最小値
    Const MAX_VALUE As Long = 30    ' 最大値

    Dim totalCount As Long
    Dim numbers() As Long
    Dim i As Long
    Dim j As Long
    Dim temp As Long
    Dim resultText As String

    totalCount = MAX_VALUE - MIN_VALUE + 1
    ReDim numbers(1 To totalCount)

    For i = 1 To totalCount
        numbers(i) = MIN_VALUE + i - 1
    Next i

    Randomize

    ' Fisher-Yatesシャッフル:末尾から順にランダムな要素と入れ替える
    For i = totalCount To 2 Step -1
        j = Int(i * Rnd) + 1
        temp = numbers(i)
        numbers(i) = numbers(j)
        numbers(j) = temp
    Next i

    For i = 1 To COUNT
        resultText = resultText & numbers(i) & " "
    Next i

    MsgBox resultText

End Sub

まずnumbers配列に1〜30の連番をすべて格納し、そのあとFisher-Yatesシャッフルで配列全体をランダムな順序に並び替えています。シャッフルは「末尾の要素から順に、先頭からその位置までの範囲でランダムに選んだ要素と入れ替える」処理を繰り返すことで、全体を均等な確率でランダム化できます。並び替えたあとは先頭からCOUNT個を取り出すだけなので、重複チェックの繰り返しが発生せず、生成個数が多い場合でも高速に動作します。

実践例:くじ引きで参加者に番号を割り振る

配列シャッフル方式を使って、参加者の一覧にランダムな抽選番号を重複なく割り当てる例です。

Sub AssignLotteryNumbers()

    Dim participantNames() As Variant
    Dim numbers() As Long
    Dim totalCount As Long
    Dim i As Long
    Dim j As Long
    Dim temp As Long

    participantNames = Array("佐藤", "鈴木", "高橋", "田中", "伊藤")
    totalCount = UBound(participantNames) - LBound(participantNames) + 1

    ReDim numbers(1 To totalCount)
    For i = 1 To totalCount
        numbers(i) = i
    Next i

    Randomize
    For i = totalCount To 2 Step -1
        j = Int(i * Rnd) + 1
        temp = numbers(i)
        numbers(i) = numbers(j)
        numbers(j) = temp
    Next i

    Cells(1, 1).Value = "氏名"
    Cells(1, 2).Value = "抽選番号"

    For i = 1 To totalCount
        Cells(i + 1, 1).Value = participantNames(i - 1)
        Cells(i + 1, 2).Value = numbers(i)
    Next i

End Sub

参加者の人数分だけ連番(1〜人数)を用意してシャッフルし、上から順にシートへ書き出すことで、一瞬で重複のない抽選番号表が完成します。参加者を増やしたい場合は、participantNamesArrayに名前を追加するだけで対応できます。

どちらの方法を使うべきか

生成したい個数が範囲全体に対して少ない場合(例:1〜1000から5個選ぶ)は、コードがシンプルなDictionary方式で十分です。一方、範囲全体に近い個数を重複なく取り出したい場合(例:1〜30から25個選ぶ)は、Dictionary方式だと未使用の値を引き当てにくくなり処理が遅くなるため、配列シャッフル方式を使うことをおすすめします。くじ引きや座席抽選のように「全員に番号を割り当てる」用途では、配列シャッフル方式が特に適しています。

まとめ

Rnd関数だけでは乱数の重複を防げないため、くじ引きや抽選システムを作る際は、Dictionaryによる重複チェック、または配列のFisher-Yatesシャッフルのいずれかを組み合わせる必要があります。生成する個数や範囲の広さに応じて、この2つの方法を使い分けることで、無駄のない安定した抽選マクロを作成できます。

スポンサーリンク
スポンサーリンク
ExcelVBA
シェアする
いがぴをフォローする

コメント

タイトルとURLをコピーしました