Excel

Simulate a Poker Game

Ease of Use

Intermediate

Version tested with

2000 

Submitted by:

brettdj

Description:

This code inserts a new worksheet and deals a 5-Card Poker hand to 10 players. The code requires Excel 2000 or higher. 

Discussion:

The code was written in two ways: as an example of how to use the (VBA) Dictionary Object or a VBA Collection to remove an item (dealt card) from a collection (pack of cards). 

Code:

instructions for use

			

Option Explicit Sub Poker_Dict() ' Requires a reference to the Microsoft Scripting Runtime Dim NumCards As Integer, Players As Integer Dim Suits(), Cards() Dim J As Variant, K As Variant Dim CardNum As Integer, i As Integer, v As Integer, CardPick As Integer Dim Casino As Dictionary, CardName As String Dim NewSheet As Worksheet Set Casino = New Dictionary ' number of cards NumCards = 5 ' number of players Players = 10 If NumCards * Players > 52 Then MsgBox "You have exceeded one deck!", vbCritical Exit Sub End If Application.ScreenUpdating = False 'Add a new sheet for the game Set NewSheet = ActiveWorkbook.Sheets.Add 'Requires Excel 2000+ to use Array Suits = Array("Spades", "Clubs", "Diamonds", "Hearts") Cards = Array("Ace", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", _ "Ten", "Jack", "Queen", "King") ' Add the cards to the Dictionary Object. i = 1 For Each J In Suits For Each K In Cards Casino.Add K & " of " & J, i i = i + 1 Next K Next J 'Pick a random card, deal it and remove it from the pack For i = 1 To Players NewSheet.Cells(1, i) = "Player " & i For v = 1 To NumCards CardPick = Int(Rnd() * Casino.Count) CardName = Casino.keys(CardPick) NewSheet.Cells(v + 1, i) = CardName Casino.Remove (CardName) Next v Next i 'dump undealt cards v = 1 NewSheet.Cells(v, i + 1) = "Undealt Cards" For Each J In Casino v = v + 1 NewSheet.Cells(v, i + 1) = J Next J 'Autofit columns NewSheet.UsedRange.EntireColumn.AutoFit 'show the result Application.ScreenUpdating = True Set Casino = Nothing End Sub Sub Poker_Coll() 'Uses a collection not a dictionary Dim NumCards As Integer, Players As Integer Dim Suits(), Cards() Dim J As Variant, K As Variant Dim CardNum As Integer, i As Integer, v As Integer, CardPick As Integer Dim Casino As Collection, CardName As String Dim NewSheet As Worksheet Set Casino = New Collection ' number of cards NumCards = 5 ' number of players Players = 10 If NumCards * Players > 52 Then MsgBox "You have exceeded one deck!", vbCritical Exit Sub End If Application.ScreenUpdating = False 'Add a new sheet for the game Set NewSheet = ActiveWorkbook.Sheets.Add 'Requires Excel 2000+ to use Array Suits = Array("Spades", "Clubs", "Diamonds", "Hearts") Cards = Array("Ace", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", _ "Ten", "Jack", "Queen", "King") ' Add the cards to the Collection i = 1 For Each J In Suits For Each K In Cards Casino.Add K & " of " & J i = i + 1 Next K Next J 'Pick a random card, deal it and remove it from the pack For i = 1 To Players NewSheet.Cells(1, i) = "Player " & i For v = 1 To NumCards CardPick = Int(Rnd() * Casino.Count + 1) CardName = Casino(CardPick) NewSheet.Cells(v + 1, i) = CardName Casino.Remove (CardPick) Next v Next i 'dump undealt cards v = 1 NewSheet.Cells(v, i + 1) = "Undealt Cards" For Each J In Casino v = v + 1 NewSheet.Cells(v, i + 1) = J Next J NewSheet.UsedRange.EntireColumn.AutoFit Application.ScreenUpdating = True Set Casino = Nothing End Sub

How to use:

  1. Copy the code above.
  2. Open your workbook.
  3. Hit Alt+F11 to open the Visual Basic Editor (VBE).
  4. From the menu, choose Insert-Module.
  5. Paste the code into the code window at right.
  6. While in the VBE, choose Tools - References and put a check in MicroSoft Scripting Runtime.
  7. Close the VBE, and save the file if desired.
 

Test the code:

  1. Run the macro by going to Tools-Macro-Macros and double-click Poker_Dict for the Dictionary method, or Poker_Coll for the Collection method.
 

Sample File:

poker.zip 9.3KB 

Approved by mdmackillop


This entry has been viewed 381 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2014 VBA Express