12
\$\begingroup\$

This is a follow-up on my previous question about a VBA macro for randomizing a draw from a table. It can be found here: Randomizing Civilization 5 team choice

The code has been improved with the help I got earlier and I now seek even further improvements.

Public Enum CivilizationTableColumns
        CivilizationName = 1
        CivilizationLeader = 2
End Enum
Public Enum TextColumns
        PlayerTextColumn = 1
        CivTextColumn = 2
End Enum

Public Sub Draw()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet

Dim resultsRange As Range
Set resultsRange = GetResultsRange(ws)
resultsRange.ClearContents

Dim CivilizationsTable As ListObject
Set CivilizationsTable = Worksheets("Civilizations").ListObjects("tblCivilizations")

Dim randCiv As String

For noOfPlayers = 1 To GetPlayerNum(ws)

    resultsRange.Cells(GetPlayerNameRow(ws, noOfPlayers), PlayerTextColumn).Value = GetPlayerName(noOfPlayers)

    For noOfOptions = 1 To GetOptionsNum(ws)

        Dim endOfRange As Boolean
        endOfRange = False

        While Not endOfRange


            randCiv = GetCivilizationCaption(GetRandomNum(CivilizationsTable), CivilizationsTable)
            For Z = 1 To resultsRange.Rows.Count
                If resultsRange.Cells(Z, CivTextColumn) = randCiv Then
                    Exit For
                End If
                If Z = resultsRange.Rows.Count Then
                    endOfRange = True
                End If
            Next Z
        Wend

        resultsRange.Cells(GetCivNameRow(ws, noOfPlayers, noOfOptions), CivTextColumn).Value = randCiv
    Next noOfOptions
Next noOfPlayers
End Sub

Private Function GetRandomNum(ByVal CivilizationsTable As ListObject) As Integer
    GetRandomNum = CInt(Int((CivilizationsTable.Range.Rows.Count - 1) * Rnd())) + 1
End Function

Private Function GetCivilizationCaption(ByVal index As Long, ByVal CivilizationsTable As ListObject)
    Set Row = CivilizationsTable.ListRows(index)
    civName = Row.Range(ColumnIndex:=CivilizationName)
    civLeader = Row.Range(ColumnIndex:=CivilizationLeader)
    GetCivilizationCaption = civLeader & " (" & civName & ")"
End Function

Private Function GetPlayerNum(ByVal ws As Worksheet)
    GetPlayerNum = ws.Cells(3, 3).Value
End Function

Private Function GetOptionsNum(ByVal ws As Worksheet)
    GetOptionsNum = ws.Cells(3, 7).Value
End Function

Private Function GetPlayerName(ByVal noOfPlayers As Integer) As String
    GetPlayerName = "Player " & noOfPlayers
End Function

Private Function GetCivNameRow(ByVal ws As Worksheet, ByVal noOfPlayers As Integer, ByVal noOfOptions As Integer) As Integer
    GetCivNameRow = (GetOptionsNum(ws) + 2) * (noOfPlayers - 1) + (noOfOptions + 3)
End Function

Private Function GetPlayerNameRow(ByVal ws As Worksheet, ByVal noOfPlayers As Integer) As Integer
    GetPlayerNameRow = 3 + (GetOptionsNum(ws) + 2) * (noOfPlayers - 1)
End Function

Private Function GetResultsRange(ByVal ws As Worksheet) As Range
    Set GetResultsRange = ws.Range("K1:L50")
End Function
\$\endgroup\$
3
  • 1
    \$\begingroup\$ I don't see Option Explicit specified.. is it? \$\endgroup\$ Mar 9 '15 at 21:21
  • \$\begingroup\$ I'm a big fan of Civ5 and I wonder how is this different that the random choice you can pick when you choose your civilization ? \$\endgroup\$
    – Marc-Andre
    Mar 10 '15 at 14:25
  • \$\begingroup\$ This is meant to be a Civ-picker for a multiplayer game. Some friends wanted a program that would randomize sets of Civs to each player from which you could choose your favorite. \$\endgroup\$ Mar 10 '15 at 21:33
6
\$\begingroup\$

Your indentation is generally fine, except the Draw procedure isn't indented as it should; everything in a Sub block should be indented 1 level, so that this:

Next noOfPlayers
End Sub

Becomes that:

    Next noOfPlayers
End Sub

I like that you have lots of small functions - that's very good!

However Draw could be further broken down; I'm removing the fluff to illustrate:

Public Sub Draw()
    For
        For
            While
                For
                    '...
                Next
            Wend
        Next
    Next
End Sub

That's 4 layers of nested loops! I've seen worse arrow code, but I'd extract a method out of the body of the 2nd For loop, to make it look like this:

Public Sub Draw()
    For
        For
            ExtractedMethodCall
        Next
    Next
End Sub

Other than that, looks great!

\$\endgroup\$
4
  • 2
    \$\begingroup\$ 4 levels of nested loops indicates significant performance problems too... is there a better algorithm? \$\endgroup\$
    – rolfl
    Mar 10 '15 at 1:11
  • 1
    \$\begingroup\$ @rolfl right - extracting half of it into another method is just lipstick on a pig. I purposely left it out; the ExtractedMethodCall would probably be actually called something like FindLastRow - and yes, there are much better ways to do that! ..but then, what will other answers say? \$\endgroup\$ Mar 10 '15 at 1:17
  • \$\begingroup\$ Actually, now that I look at it more closely.. it's.... ..not clear at all what's going on there. \$\endgroup\$ Mar 10 '15 at 1:21
  • 1
    \$\begingroup\$ @Mat'sMug From what I understand, While Not endOfRange and the innermost for-loop is doing a duplicate-check to make sure that the same civilization is not selected twice. Think of it as a alreadyPickedSelections.AnyMatch(s => s.Value == newlyPickedCivilization) . If this were C#/Java I would do it by first creating a list of the available civilizations to pick from, and then repeatedly removing one random civilization from it until there's either no civilizations left or enough civilizations has been picked. \$\endgroup\$ Mar 10 '15 at 12:20
2
\$\begingroup\$

First I'd like to say that this is a vast improvement over your original code. It's nice to see advice given on CR taken to heart and implemented. Well done. Now that it's easier to understand what the code is doing, let's talk about performance.

As @Mat'sMug mentioned in his answer, the code has nested loops 4 levels deep. That's bound to be a performance killer. I think we can solve this by storing some information in a dictionary instead. You'll need to add a reference to the Scripting Runtime to get access to the dictionary class. (It can be late bound too, but my example will be early bound and require a reference.)

The reason for the deepest loop is so you don't duplicate any civilizations in your results. We can do away with this by storing the possible civilizations in the dictionary and remove each one from the dictionary of possible entries as we use it. Retrieving an item from a dict is an \$O(1)\$ operation, so this should result in an improvement. Most of the time... there are other considerations.

First we need a way to create a dictionary from your data table, so create a private module level variable.

Private Options As Scripting.Dictionary

And a method to initialize it.

Private Sub InitializeCivilizationDict()
    Set Options = New Scripting.Dictionary

    Dim CivilizationsTable As ListObject
    Set CivilizationsTable = Worksheets("Civilizations").ListObjects("tblCivilizations")

    Dim item As ListRow
    Dim i As Long

    With CivilizationsTable.ListRows
        For i = 1 To .Count
            dict.Add .item(i).Range(ColumnIndex:=CivilizationName).Value, _
                     .item(i).Range(ColumnIndex:=CivilizationLeader).Value
        Next i
    End With

End Sub

And a data structure to represent a civilization.

Private Type Civilization
    Name As String
    Leader As String
End Type

And a slight change to your GetRandomNum function.

Private Function GetRandomNum(ByVal max As Integer) As Integer
    GetRandomNum = CInt(Int((max) * Rnd())) + 1
End Function

Now we implement a way to get a random civilization from the dictionary, and remove it as it gets returned.

Private Function GetRandomCivilization() As Civilization

    Dim randIndex As Integer
    randIndex = GetRandomNum(Options.Count)

    Dim result As Civilization
    result.Name = Options.Keys(randIndex)
    result.Leader = Options.Items(randIndex)

    Options.Remove result.Name

    GetRandomCivilizationFromDict = result
End Function

A new function to format the caption. (This replaces GetCivilizationCaption.)

Private Function FormatCivilizationCaption(ByVal civName As String, ByVal civLeader As String) As String
    FormatCivilizationCaption = civLeader & " (" & civName & ")"
End Function

Finally, we'll work these new methods into your Draw routine.

Public Sub Draw()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet

    Dim resultsRange As Range
    Set resultsRange = GetResultsRange(ws)
    resultsRange.ClearContents

    Dim CivilizationsTable As ListObject
    Set CivilizationsTable = Worksheets("Civilizations").ListObjects("tblCivilizations")


    Dim randCiv As String
    Dim noOfPlayers As Integer

    InitializeCivilizationDict

    For noOfPlayers = 1 To GetPlayerNum(ws)

        resultsRange.Cells(GetPlayerNameRow(ws, noOfPlayers), PlayerTextColumn).Value = GetPlayerName(noOfPlayers)

        Dim noOfOptions As Integer
        For noOfOptions = 1 To GetOptionsNum(ws)

            Dim civ As Civilization
            civ = GetRandomCivilization

            resultsRange.Cells(GetCivNameRow(ws, noOfPlayers, noOfOptions), CivTextColumn).Value = FormatCivilizationCaption(civ.Name, civ.Leader)
        Next noOfOptions
    Next noOfPlayers
End Sub

So, we've eliminated one whole loop and moved another out side of the nesting. A significant performance improvement on paper. I didn't bench mark it.

The whole code is below.

Option Explicit

Public Enum CivilizationTableColumns
    CivilizationName = 1
    CivilizationLeader = 2
End Enum

Public Enum TextColumns
    PlayerTextColumn = 1
    CivTextColumn = 2
End Enum

Private Type Civilization
    Name As String
    Leader As String
End Type

Private Options As Scripting.Dictionary

Public Sub Draw()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet

    Dim resultsRange As Range
    Set resultsRange = GetResultsRange(ws)
    resultsRange.ClearContents

    Dim CivilizationsTable As ListObject
    Set CivilizationsTable = Worksheets("Civilizations").ListObjects("tblCivilizations")


    Dim randCiv As String
    Dim noOfPlayers As Integer

    InitializeCivilizationDict

    For noOfPlayers = 1 To GetPlayerNum(ws)

        resultsRange.Cells(GetPlayerNameRow(ws, noOfPlayers), PlayerTextColumn).Value = GetPlayerName(noOfPlayers)

        Dim noOfOptions As Integer
        For noOfOptions = 1 To GetOptionsNum(ws)

            Dim civ As Civilization
            civ = GetRandomCivilization

            resultsRange.Cells(GetCivNameRow(ws, noOfPlayers, noOfOptions), CivTextColumn).Value = FormatCivilizationCaption(civ.Name, civ.Leader)
        Next noOfOptions
    Next noOfPlayers
End Sub

Private Sub InitializeCivilizationDict()
    Set Options = New Scripting.Dictionary

    Dim CivilizationsTable As ListObject
    Set CivilizationsTable = Worksheets("Civilizations").ListObjects("tblCivilizations")

    Dim item As ListRow
    Dim i As Long

    With CivilizationsTable.ListRows
        For i = 1 To .Count
            Options.Add .item(i).Range(ColumnIndex:=CivilizationName).Value, _
                     .item(i).Range(ColumnIndex:=CivilizationLeader).Value
        Next i
    End With

End Sub

Private Function GetRandomNum(ByVal max As Integer) As Integer
    GetRandomNum = CInt(Int((max - 1) * Rnd()))
End Function

Private Function GetRandomCivilization() As Civilization

    Dim randIndex As Integer
    randIndex = GetRandomNum(Options.Count)

    Dim result As Civilization
    result.Name = Options.Keys(randIndex)
    result.Leader = Options.Items(randIndex)

    Options.Remove result.Name

    GetRandomCivilization = result
End Function
Private Function FormatCivilizationCaption(ByVal civName As String, ByVal civLeader As String) As String
    FormatCivilizationCaption = civLeader & " (" & civName & ")"
End Function

Private Function GetPlayerNum(ByVal ws As Worksheet)
    GetPlayerNum = ws.Cells(3, 3).Value
End Function

Private Function GetOptionsNum(ByVal ws As Worksheet)
    GetOptionsNum = ws.Cells(3, 7).Value
End Function

Private Function GetPlayerName(ByVal noOfPlayers As Integer) As String
    GetPlayerName = "Player " & noOfPlayers
End Function

Private Function GetCivNameRow(ByVal ws As Worksheet, ByVal noOfPlayers As Integer, ByVal noOfOptions As Integer) As Integer
    GetCivNameRow = (GetOptionsNum(ws) + 2) * (noOfPlayers - 1) + (noOfOptions + 3)
End Function

Private Function GetPlayerNameRow(ByVal ws As Worksheet, ByVal noOfPlayers As Integer) As Integer
    GetPlayerNameRow = 3 + (GetOptionsNum(ws) + 2) * (noOfPlayers - 1)
End Function

Private Function GetResultsRange(ByVal ws As Worksheet) As Range
    Set GetResultsRange = ws.Range("K1:L50")
End Function
\$\endgroup\$

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.