4
\$\begingroup\$

I thought I'd give a shot at creating my own version of dealing 5-card hands to n players in VBA, printing them to columns and coloring hearts and diamonds red.

I felt I might have been a little repetitive and I had to jump through some hoops to avoid ByRef. Anyhow, what can I improve?

Option Explicit

Public Sub DealCards()
    'Just dealing to sheet2
    Sheet2.Range("A:Z").Clear
    Dim numberOfPlayers As Long
    numberOfPlayers = GetPlayers
    If numberOfPlayers = 0 Then Exit Sub
    Dim i As Long
    Dim myPlayers As Variant

    ReDim myPlayers(1 To numberOfPlayers, 1 To 6)

    myPlayers = DealDeck(numberOfPlayers)
    Sheet2.Range(Cells(1, 1), Cells(6, numberOfPlayers)) = Application.WorksheetFunction.Transpose(myPlayers)

    Colorize numberOfPlayers

End Sub

Private Function GetPlayers() As Long
    Dim result As Long
    result = Application.InputBox("How many players?", "Number of Players", 2, Type:=1)
        If result > 9 Or result = 0 Then
            MsgBox "There aren't enough chairs or players for this game!"
            GetPlayers = 0
            Exit Function
        End If
    GetPlayers = result
End Function

Private Function DealDeck(ByVal numberOfPlayers As Long) As Variant
    Dim dealHands As Variant
    ReDim dealHands(1 To numberOfPlayers, 1 To 6)
    Dim i As Long
    For i = 1 To numberOfPlayers
        dealHands(i, 1) = "Player" & i
    Next

    Dim myDeck(1 To 52) As Variant
    Dim hand As Long
    Dim card As Long
    Dim handPosition As Long
    For hand = 1 To numberOfPlayers
        For handPosition = 2 To 6
TryAgain:
            card = Int(52 * Rnd + 1)
            If IsEmpty(myDeck(card)) Then
                myDeck(card) = dealHands(hand, 1)
                dealHands(hand, handPosition) = ConvertCards(card)
            Else: GoTo TryAgain
            End If
        Next handPosition
    Next hand
    DealDeck = dealHands

End Function

Private Function ConvertCards(ByVal card As Long) As String
    Dim club As String
    club = ChrW(9827)
    Dim diamond As String
    diamond = ChrW(9830)
    Dim heart As String
    heart = ChrW(9829)
    Dim spade As String
    spade = ChrW(9824)
    Select Case card

        Case 1 To 13
            ConvertCards = club
            If card = 1 Or card > 10 Then
                ConvertCards = ConvertCards & FaceCard(card)
            Else: ConvertCards = ConvertCards & card
            End If

        Case 14 To 26
            ConvertCards = diamond
            If card = 14 Or card > 23 Then
                ConvertCards = ConvertCards & FaceCard(card)
            Else: ConvertCards = ConvertCards & card - 13
            End If

        Case 27 To 39
            ConvertCards = heart
            If card = 27 Or card > 36 Then
                ConvertCards = ConvertCards & FaceCard(card)
            Else: ConvertCards = ConvertCards & card - 26
            End If

        Case 40 To 52
            ConvertCards = spade
            If card = 40 Or card > 49 Then
                ConvertCards = ConvertCards & FaceCard(card)
            Else: ConvertCards = ConvertCards & card - 39
        End If

    End Select
End Function

Private Function FaceCard(ByVal card As Long) As String
    Select Case card

    Case 1, 14, 27, 40
        FaceCard = "A"
    Case 11, 24, 37, 50
        FaceCard = "J"
    Case 12, 25, 38, 51
        FaceCard = "Q"
    Case 13, 26, 39, 52
        FaceCard = "K"
    End Select

End Function

Private Sub Colorize(ByVal numberofcolumns As Long)
    Dim i As Long
    Dim j As Long
    For i = 2 To 6
        For j = 1 To numberofcolumns
            If AscW(Left(Cells(i, j), 1)) = 9829 Or AscW(Left(Cells(i, j), 1)) = 9830 Then Cells(i, j).Font.Color = RGB(255, 0, 0)
        Next j
    Next i
End Sub
\$\endgroup\$

3 Answers 3

4
\$\begingroup\$

Being a Casino Dealer I felt that I have to answer this one.

Objective:

The dealer is going to dealer cards out of a deck to N number of players until each player has a 5 card hand.

So what are the logical units? Let's look at the nouns in the Objective for clues. We have a dealer, players, hands, a deck and cards. I think that each of these should be it's own class.

When writing classes it is helps to think of a class as an object. What are the properties and attributes of the object? What actions can the object perform? Aren't properties and attributes just variables? Actions, well an action, that's what methods perform.

Playing Cards

What are the properties and attributes of a playing card?

  • Rank
  • Suit Name
  • Suit Character
  • Suit Name
  • Color

What actions can the Card perform? None really, but it makes since to have it place itself. Instead of asking the card what rank, suit, and color are you, we'll just say card here is your destination place yourself there.

PlayingCard Class

Option Explicit

Private CardValues()
Private CardCharValues()
Private CardSuitNames()
Private CardSuitChars()
Private CardColors()

Public Rank As Integer
Public Suit As Integer

Private Sub Class_Initialize()
    CardValues = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)
    CardCharValues = Array(2, 3, 4, 5, 6, 7, 8, 9, 10, "J", "Q", "K", "A")
    CardSuitNames = Array("Hearts", "Clubs", "Diamonds", "Spades")
    CardSuitChars = Array(ChrW(9829), ChrW(9827), ChrW(9830), ChrW(9824))
    CardColors = Array(RGB(255, 0, 0), RGB(0, 0, 0), RGB(255, 0, 0), RGB(0, 0, 0))
End Sub

Public Sub PlaceCard(Desination As Range)
    Desination.Value = Me.Text
    Desination.Font.Color = Me.Color
End Sub

Public Function Color() As Long
    Color = CardColors(Suit)
End Function

Public Function Text() As String
    Text = CardCharValues(Rank) & CardSuitChars(Suit)
End Function

Public Function Value() As Integer
    Value = CardValues(Rank)
End Function

Deck of Cards

What is a deck of cards? A deck of cards is a collection of 52 cards.

  • Cards as Collection

    There are 4 suits with 13 cards in each suit.

    For i = 0 To 3
        For j = 0 To 12
            Set card = New PlayingCard
            card.Rank = j
            card.Suit = i
            Cards.Add card
        Next
    Next

Once you take a card out of the deck, it is gone. You can't use it again.

    Set NextCard = Cards.Item(i)
    Cards.Remove i

DeckOfCards Class

Option Explicit

Private Cards As Collection

Private Sub Class_Initialize()
    Me.Shuffle
End Sub

Public Function NextCard() As PlayingCard
    Dim i As Integer
    i = Int((Rnd * Cards.Count) + 1)
    Set NextCard = Cards.Item(i)
    Cards.Remove i
End Function

Public Function hasNextCard() As Boolean
    hasNextCard = Cards.Count
End Function

Public Sub Shuffle()
    Dim i As Integer, j As Integer
    Dim card As PlayingCard
    Set Cards = New Collection

    For i = 0 To 3
        For j = 0 To 12
            Set card = New PlayingCard
            card.Rank = j
            card.Suit = i
            Cards.Add card
        Next
    Next
End Sub

Test

Sub DealTenDeckOfCards()
    Dim deck As New DeckOfCards
    Dim card As PlayingCard
    Dim i As Integer, j As Integer

    Application.ScreenUpdating = False
    For i = 1 To 10
        j = 1
        Do While deck.hasNextCard
            Set card = deck.NextCard
            card.PlaceCard Cells(i, j)
            j = j + 1
        Loop
        deck.Shuffle
    Next
    Application.ScreenUpdating = True
End Sub

enter image description here

\$\endgroup\$
3
  • \$\begingroup\$ Geez, that seems like so much less to accomplish the same thing, awesome. Thanks! \$\endgroup\$ Jun 24, 2016 at 13:20
  • \$\begingroup\$ With the logic being encapsulated it will be much easier to extend. Try writing a hand class. The hand needs a spot for the cards, this should be a property. hand.spot = range("A5:E5"). It'll also need to have a cards collection in it. You'll can add cards to it like hand.addCard deck.NextCard. The hand should have a rank for comparison...this is pretty complicated..maybe start with highest card value. \$\endgroup\$
    – user109261
    Jun 24, 2016 at 13:32
  • \$\begingroup\$ I'd upvote this twice if I could. Once for your fabulous output. And again because you bother to use Classes. Not something I see a lot of. +++ \$\endgroup\$
    – Gareth
    Jun 27, 2016 at 7:55
4
\$\begingroup\$

Your code assumes Sheet2 is active, and throws run-time error 1004 on this line if that's not the case:

Sheet2.Range(Cells(1, 1), Cells(6, numberOfPlayers)) = Application.WorksheetFunction.Transpose(myPlayers)

As the latest Rubberduck build could have told you, Cells implicitly references ActiveSheet:

Implicit references to the active sheet make the code frail and harder to debug. Consider making these references explicit when they're intended, and prefer working off object references.

Here are the rest of the relevant inspection results:

Warning: Member 'Cells' implicitly references ActiveSheet - (Book2) VBAProject.Module1, line 15
Warning: Member 'Cells' implicitly references ActiveSheet - (Book2) VBAProject.Module1, line 15
Warning: Member 'Cells' implicitly references ActiveSheet - (Book2) VBAProject.Module1, line 121
Warning: Member 'Cells' implicitly references ActiveSheet - (Book2) VBAProject.Module1, line 121
Warning: Member 'Cells' implicitly references ActiveSheet - (Book2) VBAProject.Module1, line 121
Suggestion: Consider renaming variable 'i' - (Book2) VBAProject.Module1, line 9
Suggestion: Consider renaming variable 'i' - (Book2) VBAProject.Module1, line 35
Suggestion: Consider renaming variable 'i' - (Book2) VBAProject.Module1, line 117
Suggestion: Consider renaming variable 'j' - (Book2) VBAProject.Module1, line 118
Warning: Variable 'i' is never assigned - (Book2) VBAProject.Module1, line 9
Warning: variable 'i' is not used - (Book2) VBAProject.Module1, line 9

Notice DealCards is declaring variable i which is neither assigned nor referred to, and can be safely removed.

DealCards would be more robust like this:

Public Sub DealCards()

    Dim target As Worksheet
    Set target = Sheet2 'Just dealing to sheet2
    target.Range("A:Z").Clear

    Dim numberOfPlayers As Long
    numberOfPlayers = GetPlayers
    If numberOfPlayers = 0 Then Exit Sub

    Dim myPlayers As Variant

    ReDim myPlayers(1 To numberOfPlayers, 1 To 6)    
    myPlayers = DealDeck(numberOfPlayers)

    With target
        .Range(.Cells(1, 1), .Cells(6, numberOfPlayers)) = Application.WorksheetFunction.Transpose(myPlayers)
    End With

    Colorize numberOfPlayers

End Sub

Now, Colorize also implicitly works off the ActiveSheet, so it would need to be given a Worksheet parameter:

Private Sub Colorize(ByVal numberofcolumns As Long, ByVal target As Worksheet)

And properly qualify its Cells calls with it.

\$\endgroup\$
8
  • \$\begingroup\$ Assumes it is active - as in it assumes it exists in the workbook that's currently open? \$\endgroup\$ Jun 23, 2016 at 14:20
  • \$\begingroup\$ Try running it with Sheet1 active. \$\endgroup\$ Jun 23, 2016 at 14:41
  • \$\begingroup\$ huh, I don't understand how targeting a variable is different than targeting the underlying value of what the variable would be. You said it has to do with cells vs range? I'll have to look that up, thanks! \$\endgroup\$ Jun 23, 2016 at 14:45
  • \$\begingroup\$ No, I mean Cells is calling [_Global].Cells, which is equivalent to ActiveSheet.Cells; this fails because Sheet2.Range is qualified with Sheet2, but you're giving Range cell references that aren't necessarily in that worksheet. \$\endgroup\$ Jun 23, 2016 at 14:48
  • \$\begingroup\$ Oh, so something like Sheet2.Range(Sheet2.Cells(i,j),Sheet2.Cells(k,l)) would not error? \$\endgroup\$ Jun 23, 2016 at 14:51
2
\$\begingroup\$

following your "no-Class" approach here's my contribution

  1. "divide et impera"

    divide your code into subs/functions to keep it more readable and maintenable

    Sub main()
    Dim gameSheet As Worksheet
    Dim numberOfPlayers As Integer
    Dim myPlayers As Variant
    Dim playersRng As Range
    Dim nCards As Integer: nCards = 52
    ReDim myDeck(1 To nCards) As Integer
    
    'handle the player number
    numberOfPlayers = GetPlayers
    If numberOfPlayers = 0 Then Exit Sub
    
    Set gameSheet = Worksheets("Game") '<--|set the "game table"!
    DealCards numberOfPlayers, gameSheet, nCards, myPlayers, myDeck, playersRng '<--|deal cards to players and get back what you need to go on with the game
    
    ' code to go on with the game
    ' you have:
    ' - myDeck, with remaining nCards
    ' - myPlayers , with the players' cards
    ' - playersRng, with the range showing players' cards
    
    End Sub
    

    we'll see each sub in detail

  2. GetPlayers

    some little optimizations

    you don't need result variable, you must handle any negative input and can have the code more linear as follows:

    Private Function GetPlayers() As Integer
    GetPlayers = Application.InputBox("How many players?", "Number of Players", 2, Type:=1)
    If GetPlayers > 9 Or GetPlayers < 1 Then
        MsgBox "There aren't enough chairs or players for this game!"
        GetPlayers = 0
    End If
    End Function
    
  3. DealCards

    this is the actual more important sub of the ones we're dealing with, but it will turned to a simple list of operations

    Public Sub DealCards(numberOfPlayers As Integer, gameSheet As Worksheet, nCards As Integer, myPlayers As Variant, myDeck() As Integer, playersRng As Range)
    GetDeck myDeck, nCards '<--| get your brand new cards deck
    DealDeck myDeck, nCards, numberOfPlayers, myPlayers '<--| deal your players the deck
    LayDownCards gameSheet, numberOfPlayers, myPlayers, playersRng  '<--| show the laydown
    End Sub
    

    we'll see each listed task in detail

  4. GetDeck

    it simply sets up a new deck of cards by means of a integers sequence

    Sub GetDeck(ByRef deck() As Integer, ByVal nCards As Integer)
    Dim i As Integer
    For i = 1 To nCards
        deck(i) = i
    Next i
    End Sub
    
  5. DealDeck

    Private Sub DealDeck(ByRef myDeck() As Integer, nCards As Integer, ByVal numberOfPlayers As Integer, dealHands As Variant)
    Dim hand As Integer
    Dim handPosition As Integer
    
    InitDealHands dealHands, numberOfPlayers '<--| initialize your "dealHands" variant with players' name
    
    For hand = 1 To numberOfPlayers
        For handPosition = 2 To 6
            dealHands(hand, handPosition) = ConvertCards(GetCard(myDeck, nCards)) '<--| fill dealhands "cards" slots
        Next handPosition
    Next hand
    ReDim Preserve myDeck(1 To nCards) '<--| redim the deck to last present card
    End Sub
    

    its task is filling the dealHands variant array

    it firstly initializes the players' names:

    InitDealHands dealHands, numberOfPlayers
    

    calling InitDealHands() sub, which is:

    Function InitDealHands(dealHands As Variant, ByVal numberOfPlayers As Integer)
    Dim i As Integer
    
    ReDim dealHands(1 To numberOfPlayers, 1 To 6) As Variant '''
    For i = 1 To numberOfPlayers
        dealHands(i, 1) = "Player" & i
    Next
    End Function
    

    and then fills the cards slots:

    (loop)
    dealHands(hand, handPosition) = ConvertCards(GetCard(myDeck, nCards))
    

    each card is taken from the deck by means of GetCard() sub:

    Function GetCard(deck() As Integer, nCards As Integer)
    Dim card As Integer
    
    card = Int(nCards * Rnd + 1)
    GetCard = deck(card)
    deck(card) = deck(nCards)
    nCards = nCards - 1
    End Function
    

    here you don't have neither to attempt random numbers until finding an "unused" one nor redim any array at every chosen card.

    you simply have the random function choose an integer between 1 and the actual deck remaining cards counter (nCards), then swap the current last deck card with the chosen one and finally "shorten" the deck it by updating nCards (nCards = nCards - 1)

    GetCard() returns an integer that needs to be converted to its corresponding "face" by ConvertCards() sub:

    Private Function ConvertCards(ByVal card As Integer) As String
    Dim seeds(1 To 4) As String
    Dim seed As Integer, seedCard As Integer
    
    seeds(1) = ChrW(9827) 'clubs
    seeds(2) = ChrW(9830) 'diamond
    seeds(3) = ChrW(9829) 'hearts
    seeds(4) = ChrW(9824) 'spades
    
    seedCard = IIf(card Mod 13 = 0, 13, card Mod 13)
    seed = Int(card / 13) + IIf(seedCard = 13, 0, 1)
    
    If seedCard = 1 Or seedCard > 10 Then
        ConvertCards = seeds(seed) & FaceCard(seedCard)
    Else
        ConvertCards = seeds(seed) & seedCard
    End If
    End Function
    

Which is greatly shortened if compared with your initial corresponding sub by means of the exploitation of Mod() function


Also FaceCard() function is greatly shortened

Private Function FaceCard(ByVal card As Integer) As String
    Select Case card
        Case 1
            FaceCard = "A"
        Case Else
            FaceCard = Choose(card - 10, "J", "Q", "K")
    End Select
End Function

this is done by:

  • exploiting the fact that it's called by ConvertCards() only when needed (If seedCard = 1 Or seedCard > 10 Then)

  • thus having to select between the case of an "Ace" and all other relevant ones


  1. LayDownCards

    this sub has the task of laying down the dealt cards onto the game table

    so it first lays them down uncoloured:

    With sht
        .Range("A:Z").Clear
        Set playersRng = .Range(.Cells(1, 1), .Cells(6, numberOfPlayers)) 
    End With
    playersRng = Application.WorksheetFunction.Transpose(myPlayers) 
    

    while setting playersRange Range that will be passed up to the main sub

    and the "colorizes" them:

    Private Sub Colorize(ByVal playersRng As Range)
    Dim cell As Range
    
    For Each cell In playersRng
        Select Case AscW(Left(cell, 1))
            Case 9829 To 9830
                cell.Font.Color = RGB(255, 0, 0)
        End Select
    Next cell
    End Sub
    

    which exploits the Range variable passed in to loop through it

\$\endgroup\$
5
  • \$\begingroup\$ @ThomasInzina: begin listing those flaws here and let's discuss them \$\endgroup\$ Jun 27, 2016 at 13:58
  • \$\begingroup\$ I apologize that I didn't word my comment better. It's going to be a couple of days before I have the time but I like move the discussion to a chat room and invite Mat's Mug. Mat's is very professional and his code reviews are solid. I would appreciate it if he could review my own assessment and methodology. \$\endgroup\$
    – user109261
    Jun 27, 2016 at 15:31
  • \$\begingroup\$ Thanks, I'm away from computers while I'm moving, but I will give this a look over when I get back online! \$\endgroup\$ Jun 28, 2016 at 20:25
  • \$\begingroup\$ @Raystafarian did you have a look at this? \$\endgroup\$ Jul 27, 2016 at 14:21
  • \$\begingroup\$ Thanks for the bump,I haven't been active since the move. I'll hopefully get to that by next week \$\endgroup\$ Jul 29, 2016 at 18:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.