Jacob Hilderbrand
03-11-2006, 01:03 PM
Ok, so this game is kinda interesting. If you haven't seen it, the premise is simple.
There are 26 cases, each one has a dollar amount in it from $.01 to $1,000,000. You pick one case for yourself, then start picking the other cases. Based on the other cases that you open, we can illiminate what values are not in your case (since they have been picked).
After each round of picking cases, you will be offered a deal by the banker to sell your case. This value will change based on what could possibly be in your case (i.e. if there are a lot of high numbers still available your offer will be better).
So I decided to recreate this game in Excel to see how it would work. I am not 100% sure of the exact calculations used for the show, so I am just calculating the expected value of the case.
So give it a try and let me know what you think.
To start the game, just click on the Deal Or No Deal banner at the top of the worksheet. Then click on your case. Then begin removing cases. The number of cases to remove before the next offer is in A17. You will have to pick 6 the first round, then 5, then 4 etc.
Here is the code.
Option Explicit
Dim CaseValues As Collection
Dim Picks As Long
Dim Offer As Long
Dim StartGame As Boolean
Sub NewGame()
Dim Shp As Shape
Dim i As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
StartGame = False
With DealOrNoDeal
.Unprotect
On Error Resume Next
.Shapes("Your Case").Delete
On Error GoTo 0
Call SetValues
.EnableSelection = xlNoSelection
For Each Shp In .Shapes
Shp.Visible = msoCTrue
Next
For i = 1 To 13
.Range("A" & i).Value = Setup.Range("A" & i + 1).Value
.Range("N" & i).Value = Setup.Range("A" & i + 14).Value
Next i
Picks = 6
Range("A17").Value = Picks
.Protect
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Shp = Nothing
End Sub
Sub CalculateOffer(Optional Dummy As Long)
Dim Cases As Long
Dim Prob As Double
Dim Cel As Range
Dim CaseRange As Range
Dim Prompt As String
Dim Title As String
Offer = 0
Set CaseRange = Range("A1:A13,N1:N13")
Cases = Application.WorksheetFunction.CountA(CaseRange)
Prob = 1 / Cases
For Each Cel In CaseRange
If Cel.Text <> "" Then
Offer = Offer + Cel.Value * Prob
End If
Next
Prompt = "The Banker is offering you " & _
Format(Offer, "$#,##0") & " to sell your case."
Title = "Deal Or No Deal?"
MsgBox Prompt, vbQuestion, Title
Set Cel = Nothing
Set CaseRange = Nothing
End Sub
Sub PickYourCase()
Dim Pick As String
Dim Cel As Range
Dim Prompt As String
Dim Title As String
DealOrNoDeal.Unprotect
Pick = Replace(Application.Caller, "Case", "")
Pick = Replace(Pick, Chr(10), "")
Select Case Pick
Case Is = "Deal"
Case Is = "No Deal"
Case Else
DealOrNoDeal.Shapes(Application.Caller).Copy
Range("A19").Select
DealOrNoDeal.Paste
Selection.OnAction = ""
Selection.Name = "Your Case"
DealOrNoDeal.Shapes(Application.Caller).Visible = msoFalse
Range("A1").Select
End Select
DealOrNoDeal.Protect
Set Cel = Nothing
End Sub
Sub PickCase(Optional Dummy As Long)
Dim Pick As String
Dim Cel As Range
Dim Prompt As String
Dim Title As String
If StartGame = False Then
Call PickYourCase
StartGame = True
Exit Sub
End If
DealOrNoDeal.Unprotect
Pick = Replace(Application.Caller, "Case", "")
Pick = Replace(Pick, Chr(10), "")
Select Case Pick
Case Is = "Deal"
If Range("A17").Value = "" Then
Prompt = "Congratulations on winning: " & Format(Offer, "$#,##0")
Title = "Game Over"
MsgBox Prompt, vbInformation, Title
End If
Case Is = "No Deal"
If Range("A17").Value = "" Then
If Picks > 1 Then
Picks = Picks - 1
End If
Range("A17").Value = Picks
End If
Case Else
If Range("A17").Text = "" Then
Call CalculateOffer
Else
DealOrNoDeal.Shapes(Application.Caller).Visible = msoFalse
Set Cel = Range("A1:A13,N1:N13").Find( _
What:=Format(CaseValues(CDbl(Pick)), "$#,##0"), _
LookIn:=xlValues, LookAt:=xlWhole)
If Cel Is Nothing Then
Set Cel = Range("A1")
End If
Cel.ClearContents
If Range("A17").Value > 1 Then
Range("A17").Value = Range("A17").Value - 1
Else
Range("A17").Value = ""
Call CalculateOffer
End If
End If
End Select
DealOrNoDeal.Protect
Set Cel = Nothing
End Sub
Sub SetValues(Optional Dummy As Long)
Dim i As Long
Dim Values As New Collection
Set CaseValues = New Collection
Randomize
For i = 2 To 27
Values.Add Setup.Range("A" & i).Text
Next i
For i = 1 To 26
Range("P" & i).Value = Rnd
Next i
For i = 1 To 26
Range("Q" & i).Value = "=Rank(P" & i & ",P:P)"
Range("R" & i).Value = Values(i)
Next i
Range("P:R").Sort Key1:=Range("Q1"), Order1:=xlAscending
For i = 1 To 26
CaseValues.Add Range("R" & i).Value
Next i
Range("P:R").ClearContents
Set Values = Nothing
End Sub
There are 26 cases, each one has a dollar amount in it from $.01 to $1,000,000. You pick one case for yourself, then start picking the other cases. Based on the other cases that you open, we can illiminate what values are not in your case (since they have been picked).
After each round of picking cases, you will be offered a deal by the banker to sell your case. This value will change based on what could possibly be in your case (i.e. if there are a lot of high numbers still available your offer will be better).
So I decided to recreate this game in Excel to see how it would work. I am not 100% sure of the exact calculations used for the show, so I am just calculating the expected value of the case.
So give it a try and let me know what you think.
To start the game, just click on the Deal Or No Deal banner at the top of the worksheet. Then click on your case. Then begin removing cases. The number of cases to remove before the next offer is in A17. You will have to pick 6 the first round, then 5, then 4 etc.
Here is the code.
Option Explicit
Dim CaseValues As Collection
Dim Picks As Long
Dim Offer As Long
Dim StartGame As Boolean
Sub NewGame()
Dim Shp As Shape
Dim i As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
StartGame = False
With DealOrNoDeal
.Unprotect
On Error Resume Next
.Shapes("Your Case").Delete
On Error GoTo 0
Call SetValues
.EnableSelection = xlNoSelection
For Each Shp In .Shapes
Shp.Visible = msoCTrue
Next
For i = 1 To 13
.Range("A" & i).Value = Setup.Range("A" & i + 1).Value
.Range("N" & i).Value = Setup.Range("A" & i + 14).Value
Next i
Picks = 6
Range("A17").Value = Picks
.Protect
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Shp = Nothing
End Sub
Sub CalculateOffer(Optional Dummy As Long)
Dim Cases As Long
Dim Prob As Double
Dim Cel As Range
Dim CaseRange As Range
Dim Prompt As String
Dim Title As String
Offer = 0
Set CaseRange = Range("A1:A13,N1:N13")
Cases = Application.WorksheetFunction.CountA(CaseRange)
Prob = 1 / Cases
For Each Cel In CaseRange
If Cel.Text <> "" Then
Offer = Offer + Cel.Value * Prob
End If
Next
Prompt = "The Banker is offering you " & _
Format(Offer, "$#,##0") & " to sell your case."
Title = "Deal Or No Deal?"
MsgBox Prompt, vbQuestion, Title
Set Cel = Nothing
Set CaseRange = Nothing
End Sub
Sub PickYourCase()
Dim Pick As String
Dim Cel As Range
Dim Prompt As String
Dim Title As String
DealOrNoDeal.Unprotect
Pick = Replace(Application.Caller, "Case", "")
Pick = Replace(Pick, Chr(10), "")
Select Case Pick
Case Is = "Deal"
Case Is = "No Deal"
Case Else
DealOrNoDeal.Shapes(Application.Caller).Copy
Range("A19").Select
DealOrNoDeal.Paste
Selection.OnAction = ""
Selection.Name = "Your Case"
DealOrNoDeal.Shapes(Application.Caller).Visible = msoFalse
Range("A1").Select
End Select
DealOrNoDeal.Protect
Set Cel = Nothing
End Sub
Sub PickCase(Optional Dummy As Long)
Dim Pick As String
Dim Cel As Range
Dim Prompt As String
Dim Title As String
If StartGame = False Then
Call PickYourCase
StartGame = True
Exit Sub
End If
DealOrNoDeal.Unprotect
Pick = Replace(Application.Caller, "Case", "")
Pick = Replace(Pick, Chr(10), "")
Select Case Pick
Case Is = "Deal"
If Range("A17").Value = "" Then
Prompt = "Congratulations on winning: " & Format(Offer, "$#,##0")
Title = "Game Over"
MsgBox Prompt, vbInformation, Title
End If
Case Is = "No Deal"
If Range("A17").Value = "" Then
If Picks > 1 Then
Picks = Picks - 1
End If
Range("A17").Value = Picks
End If
Case Else
If Range("A17").Text = "" Then
Call CalculateOffer
Else
DealOrNoDeal.Shapes(Application.Caller).Visible = msoFalse
Set Cel = Range("A1:A13,N1:N13").Find( _
What:=Format(CaseValues(CDbl(Pick)), "$#,##0"), _
LookIn:=xlValues, LookAt:=xlWhole)
If Cel Is Nothing Then
Set Cel = Range("A1")
End If
Cel.ClearContents
If Range("A17").Value > 1 Then
Range("A17").Value = Range("A17").Value - 1
Else
Range("A17").Value = ""
Call CalculateOffer
End If
End If
End Select
DealOrNoDeal.Protect
Set Cel = Nothing
End Sub
Sub SetValues(Optional Dummy As Long)
Dim i As Long
Dim Values As New Collection
Set CaseValues = New Collection
Randomize
For i = 2 To 27
Values.Add Setup.Range("A" & i).Text
Next i
For i = 1 To 26
Range("P" & i).Value = Rnd
Next i
For i = 1 To 26
Range("Q" & i).Value = "=Rank(P" & i & ",P:P)"
Range("R" & i).Value = Values(i)
Next i
Range("P:R").Sort Key1:=Range("Q1"), Order1:=xlAscending
For i = 1 To 26
CaseValues.Add Range("R" & i).Value
Next i
Range("P:R").ClearContents
Set Values = Nothing
End Sub