Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Function GetRnd(lMin&, lMax&) As Long
    Randomize
    GetRnd = Int((lMax - lMin + 1) * Rnd + lMin)
End Function
'==================================================================================================
' Изменяет lTry на количество попыток
' Возвращает номер очередной выбранной двери и добавляет её в словарь
Private Function ChooseNextDoor(lMin&, lMax&, dic As Dictionary, Optional lTry&) As Long
lTry = 0
    Do
        lTry = lTry + 1
        ChooseNextDoor = GetRnd(lMin, lMax)
        If Not dic.Exists(ChooseNextDoor) Then Exit Function
    Loop
End Function
'==================================================================================================
'==================================================================================================
' Возвращает количество попыток, пройденных для нахождения искомого lPrize (статичный выбор)
Function PlayerStatic(lPrize&, lMin&, lMax&) As Long
Dim dicOpen As New Dictionary
Dim lDelta&, lChoose&, lOpen&

lDelta = lMax - lMin + 1        ' количество "дверей" в списке
If lDelta < 3 Then Stop: End
lChoose = GetRnd(lMin, lMax)    ' ВЫБИРАЕМ дверь (один раз)

Do
    PlayerStatic = PlayerStatic + 1             ' считаем попытки
    If lChoose = lPrize Then Exit Function      ' если ВЫБРАЛИ на призовую, то выходим

    lOpen = ChooseNextDoor(lMin, lMax, dicOpen) ' ОТКРЫВАЕМ очередную дверь (НЕоткрытую ранее)
    If lOpen = lPrize Then Exit Function        ' если ОТКРЫЛИ призовую, то выходим
    dicOpen.add lOpen, 0                        ' ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей очередную ОТКРЫТУЮ дверь

    If dicOpen.Count = lDelta - 1 Then          ' если открыты все, кроме одной, то ОТКРЫВАТЬ не из чего (следующим шагом гарантированно будет ОТКРЫТА ПРИЗОВАЯ дверь)
        PlayerStatic = PlayerStatic + 1
        Exit Function
    End If
Loop

End Function
'--------------------------------------------------------------------------------------------------
' Возвращает количество попыток, пройденных для нахождения искомого lPrize (постоянная смена выбора)
Function PlayerChange(lPrize&, lMin&, lMax&) As Long
Dim dicChoose As New Dictionary, dicOpen As New Dictionary
Dim lDelta&, lChoose&, lOpen&, fAllChosen As Boolean

lDelta = lMax - lMin + 1        ' количество "дверей" в списке
If lDelta < 3 Then Stop: End
dicOpen.add lPrize, 0           ' ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей ПРИЗОВУЮ дверь, чтобы не открыть

Do
    PlayerChange = PlayerChange + 1                 ' считаем попытки

    If fAllChosen Then                              ' если все двери уже были выбраны …
        dicOpen.Remove lPrize                           ' … УДАЛЯЕМ из словаря ОТКРЫТЫХ дверей ПРИЗОВУЮ, чтобы она участвовала в ВЫБОРЕ
        lChoose = ChooseNextDoor(lMin, lMax, dicOpen)   ' … ВЫБИРАЕМ очередную дверь с учётом открытых
        dicOpen.add lPrize, 0                           ' … ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей ПРИЗОВУЮ
    Else                                            ' в противном случае …
        lChoose = ChooseNextDoor(lMin, lMax, dicChoose) ' … ВЫБИРАЕМ очередную дверь с учётом ВЫБРАННЫХ и ОТКРЫТЫХ дверей ранее
    End If

    If lChoose = lPrize Then Exit Function          ' если попали на призовую, то выходим
    dicChoose.add lChoose, 0                        ' ДОБАВЛЯЕМ в словарь ВЫБРАННЫХ дверей очередную ВЫБРАННУЮ дверь

    dicOpen.add lChoose, 0                          ' ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей очередную ВЫБРАННУЮ дверь, чтобы не открыть её
    lOpen = ChooseNextDoor(lMin, lMax, dicOpen)     ' ОТКРЫВАЕМ очередную дверь (НЕпризовую, НЕоткрытую ранее и не выбранную)
    dicOpen.Remove lChoose                          ' УДАЛЯЕМ из словаря ОТКРЫТЫХ дверей очередную ВЫБРАННУЮ дверь
    dicOpen.add lOpen, 0                            ' ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей очередную ОТКРЫТУЮ дверь

    If dicOpen.Count = lDelta - 1 Then              ' если открыты все, кроме одной, то ВЫБИРАТЬ не из чего (следующим шагом гарантированно будет ВЫБРАНА ПРИЗОВАЯ дверь)
        PlayerChange = PlayerChange + 1
        Exit Function
    End If

    If dicChoose.Count = lDelta Then                ' если словарь выбранных дверей содержит все двери …
        fAllChosen = True                               ' … ставим флаг
        dicChoose.RemoveAll                             ' … очищаем словарь
    End If

    If Not fAllChosen Then
        If Not dicChoose.Exists(lOpen) Then dicChoose.add lOpen, 0   ' ДОБАВЛЯЕМ в словарь ВЫБРАННЫХ дверей очередную ОТКРЫТУЮ дверь (если ещё не все двери были выбраны)
    End If
Loop

End Function
'==================================================================================================
'==================================================================================================
Sub TestPlay()
Dim t!, l&, lPrize&, lTry&
Dim lStMin&, lStMax&, lStTot&
Dim lChMin&, lChMax&, lChTot&
Const lMin& = 1, lMax& = 10, lCyc& = 10000

lStMin = lMax
lChMin = lMax

t = Timer
    For l = 1 To lCyc
        lPrize = GetRnd(lMin, lMax) ' номер двери с призом

        lTry = PlayerStatic(lPrize, lMin, lMax)
        lStTot = lStTot + lTry
        If lStMin > lTry Then lStMin = lTry
        If lStMax < lTry Then lStMax = lTry

        lTry = PlayerChange(lPrize, lMin, lMax)
        lChTot = lChTot + lTry
        If lChMin > lTry Then lChMin = lTry
        If lChMax < lTry Then lChMax = lTry
    Next l
Debug.Print Format$(Timer - t, "0.00")

Debug.Print "Min", "Av", "Max", "Tot"

Debug.Print "St"
Debug.Print Format$(lStMin, "#,##0"), Format$(lStTot / lCyc, "#,##0.0"), Format$(lStMax, "#,##0"), Format$(lStTot, "#,##0")

Debug.Print "Ch"
Debug.Print Format$(lChMin, "#,##0"), Format$(lChTot / lCyc, "#,##0.0"), Format$(lChMax, "#,##0"), Format$(lChTot, "#,##0")

End Sub