いわゆる「お見合い問題」（≒何人と付き合えば、ベストな人と結婚できるか？という問題）についてシミュレーションしました！

「お見合い問題」概要

次のようなルール（制約）のもと、ベストな人と結婚するにはどのような戦略がよいか？　という問題です。

ルール：
● 最大 N 人と付き合う（お見合いする）
● お別れした人とは、よりを戻せない
● 結婚のプロポーズは、すれば必ず成功する
戦略：
初めの何人かは「見る目を養う期間」と割り切って"必ず別れる"。
その後、今まで出会った人の中で一番良いと思う人と結婚する。
問題：
「見る目を養う期間」として何人と付き合ってみれば、全体 N 人の中でベストな人と結婚できるか？

最大人数 N が大きいときは、大体その 1/3 よりちょっと多いくらいの人と付き合ってから、「いいな」と思った人と結婚すれば、ベストとなる確率が最高になることが知られています。以下のサイトが詳しいです。

シミュレーション

「付き合う最大人数 N が小さいときは？」
ということで、エクセルVBAを用いてシミュレートしてみました！

表の見方：
縦軸が付き合う最大人数 N、
横軸が「見る目を養う期間」の人数。
黄色で塗った数字が、その「見る目を養う期間」を採用した場合の「ベストな人と結婚できる確率」。
例：
最大 5 人と付き合うことを想定する場合、2 人と付き合って別れた後、付き合った人の中でもっとも良かった人と結婚すれば、ベストである確率が 43% である。

エクセルとVBA全文

今回使用したエクセルファイルです。

VBAの全文も載せておきます。

Option Explicit

Const N = 10000

Sub main()
   Dim persons() As Double
   Dim personsCount As Long: personsCount = Range("MAX")
   Dim gap As Long: gap = Range("GAP")
   Dim theOne As Double
   Dim count As Long
   Dim i As Long
   Dim row As Long
   Dim column As Long
   
   row = 4
   Do While Cells(row, 3) <> ""
       personsCount = Cells(row, 3)
   
       column = 4
       Do While Cells(3, column) <> ""
           gap = Cells(3, column)
           If gap > personsCount Then
               Exit Do
           End If
           
           count = 0
           For i = 1 To N
               Call 付き合う異性を配列に格納する(persons, personsCount)
               theOne = 付き合う人を決める(persons, personsCount, gap)
               
               If theOne = WorksheetFunction.Max(persons) Then
                   count = count + 1
               End If
           Next i
           
           Cells(row, column) = count / N
           
           column = column + 1
       Loop
       
       row = row + 1
   Loop
End Sub

Sub 付き合う異性を配列に格納する(persons, _
                                ByVal personsCount As Long)
   Dim i As Long
   
   ReDim persons(1 To personsCount) As Double
   For i = 1 To personsCount
       persons(i) = Rnd
   Next i
End Sub

Function 付き合う人を決める(persons, _
                           ByVal personsCount As Long, _
                           ByVal gap As Long)
   Dim i As Long
   
   For i = gap To personsCount
       If partMax(persons, i) <= persons(i) Then
           付き合う人を決める = persons(i)
           Exit For
       End If
   Next i
End Function

Function partMax(persons, _
                ByVal last As Long) As Double
   Dim ret As Double
   Dim i As Long
   
   ret = 0
   For i = 1 To last
       If ret < persons(i) Then
           ret = persons(i)
       End If
   Next i
   
   partMax = ret
End Function

―――――記事はここまで―――――
最後まで読んでくださり、ありがとうございました！