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:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
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:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
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:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
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!