VBA – Simulation of Rolling Dices

Excel and VBA are a powerful tool for simulation.

The idea is to simulate dice throwing and to keep the best N throws as our score. Other model variables are Times I roll, which stands for how many times do we roll the dice and Number of sides, which is self-explanatory. At the picture below, a standard 6-side dice is considered:

After running the code twice, we get this:

The colors in purple are the top N results, which are taken to our score. In the lone below, they are colored in yellow. After the third run, this is how the result looks like:

The main part of the VBA is this:

Public Sub Main()

    Dim numberOfSides As Long: numberOfSides = Range("A2")
    Dim timesToRoll As Long: timesToRoll = Range("B2")
    Dim howManyToKeep As Long: howManyToKeep = Range("C2")

    Dim cnt As Long
    Dim rngCurrent As Range

    Cells.Interior.Color = vbWhite
    Set rngCurrent = Range(Cells(1, 6), Cells(1, 6 + timesToRoll - 1))

    For cnt = 1 To timesToRoll
        rngCurrent.Cells(1, cnt) = makeRandom(1, numberOfSides)
    Next cnt

    Dim myArr As Variant
    With Application
        myArr = .Transpose(.Transpose(rngCurrent))
    End With

    WriteTopN howManyToKeep, myArr, Cells(2, lastCol(rowToCheck:=2))
    ColorTopCells howManyToKeep, rngCurrent, myArr

End Sub

It actually looks quite self-explanatory. We “read” the three parameters, color back everything in white and we generate the random number with makeRandom. Then, through the Transpose Trick we get an array, which is passed to the functions WriteTopN and ColorTopCells.

This is how these two subs look like:

Public Sub ColorTopCells(howManyToKeep As Long, rngCurrent As Range, myArr As Variant)
    
    Dim colorCell As Range
    Dim myCell As Range
    Dim cnt As Long
    Dim lookForValue As Long
    Dim cellFound As Boolean
    
    For cnt = 1 To howManyToKeep
        lookForValue = WorksheetFunction.Large(myArr, cnt)
        cellFound = False
        For Each myCell In rngCurrent
            If Not cellFound And myCell = lookForValue Then
                cellFound = True
                myCell.Interior.Color = vbMagenta
            End If
        Next myCell
    Next cnt
    
End Sub


Public Sub WriteTopN(N As Long, myArr As Variant, lastCell As Range)

    Dim cnt As Long
    
    For cnt = 1 To N
        Set lastCell = lastCell.Offset(0, 1)
        lastCell = WorksheetFunction.Large(myArr, cnt)
        lastCell.Interior.Color = vbYellow
    Next cnt

End Sub

At the end, these are the two standard functions for generating a random number and getting the last column:

Public Function makeRandom(down As Long, up As Long) As Long

    makeRandom = CLng((up - down + 1) * Rnd + down)

    If makeRandom > up Then makeRandom = up
    If makeRandom < down Then makeRandom = down

End Function

Function lastCol(Optional strSheet As String, Optional rowToCheck As Long = 1) As Long

    Dim shSheet  As Worksheet
        If strSheet = vbNullString Then
            Set shSheet = ActiveSheet
        Else
            Set shSheet = Worksheets(strSheet)
        End If
    lastCol = shSheet.Cells(rowToCheck, shSheet.Columns.Count).End(xlToLeft).Column

End Function

Cheers and thank you for reading!

VBA – Simulation of Rolling Dices

Related posts: