くじ引きや抽選ツールを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〜人数)を用意してシャッフルし、上から順にシートへ書き出すことで、一瞬で重複のない抽選番号表が完成します。参加者を増やしたい場合は、participantNamesのArrayに名前を追加するだけで対応できます。
どちらの方法を使うべきか
生成したい個数が範囲全体に対して少ない場合(例:1〜1000から5個選ぶ)は、コードがシンプルなDictionary方式で十分です。一方、範囲全体に近い個数を重複なく取り出したい場合(例:1〜30から25個選ぶ)は、Dictionary方式だと未使用の値を引き当てにくくなり処理が遅くなるため、配列シャッフル方式を使うことをおすすめします。くじ引きや座席抽選のように「全員に番号を割り当てる」用途では、配列シャッフル方式が特に適しています。
まとめ
Rnd関数だけでは乱数の重複を防げないため、くじ引きや抽選システムを作る際は、Dictionaryによる重複チェック、または配列のFisher-Yatesシャッフルのいずれかを組み合わせる必要があります。生成する個数や範囲の広さに応じて、この2つの方法を使い分けることで、無駄のない安定した抽選マクロを作成できます。


コメント