PDA

View Full Version : Deal Or No Deal



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

mdmackillop
03-11-2006, 03:59 PM
Hi Zack,
A quick run through
Be nicer with a userform which displays the Deal/No Deal buttons
Needs a final happy/sad result page

I watched part of this on TV here and thought it deadly dull. Your version can be played at a much faster pace.

BTW you owe me $100 :(

Regards
Malcolm

Dave
03-15-2006, 07:42 PM
Great stuff. Add some code to turn off the suitcases until the deal/no deal pic is selected on initial startup (for those of us who like selecting cases before reading any instructions...kept crashing) I think I'm also for using a modeless userform with big friendly deal buttons. A fun bit of code. Thanks! Dave