Comparing numbers in an array

Question

So the problem is more in depth than a simple comparison. Essentially im trying to model this dice roll known as the roll and keep system. Example would be 5k3. Where I would roll 5 dice and keep the 3 highest then add them together.

I've gotten my little macro program to roll the dice. Then I put them in an array in my example that would be an array with 5 indices. Now I need to take those 5 dice, and only keep the largest 3 of them.

The code is here A2 gives me the number of sides on the dice, B2 gives me how many I roll, and C2 gives me how many I keep. This rolls 10 dice, but then I transfer 5 of them into my actual dicepool. I know I could probably skip that, but I can deal with that later.

Private Sub CommandButton1_Click()

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim RandNum As Integer
Dim RollArray() As Integer
Dim KeptArray() As Integer
Dim RollArrayDummy() As Integer
Dim NumRoll As Integer
Dim Kept As Integer
Dim Largest As Integer

NumRoll = Range("B2").Value
ReDim RollArray(NumRoll)

Kept = Range("C2").Value
ReDim KeptArray(Kept)

For i = 5 To 15
Randomize

    RandNum = 1 + Rnd() * (Range("A2").Value - 1)
    Cells(i, 1).Value = RandNum
Next i

For j = 1 To NumRoll
    RollArray(j) = Cells(4 + j, 1).Value
    Cells(4 + j, 2).Value = RollArray(j)
Next j

k = 1
i = 1
m = 1
Largest = 1
For k = 1 To Kept
m = 1
KeptArray(k) = Largest

    If m <= NumRoll Then
        If Largest >= RollArray(m) And Largest >= KeptArray(k) Then
            Largest = KeptArray(k)
        Else
            KeptArray(k) = Largest
            Largest = RollArray(m)
        End If
    m = m + 1
    End If

Cells(4 + k, 3).Value = KeptArray(k)

Next k

End Sub

I've tried so many things, like creating a dummy array, and comparing the variable Largest with it. And a ton of other things. My big problem is that I can't reuse any of the numbers.

If I roll 5 and keep 3. Say I roll [4,2,3,3,6] . I keep the [6,4,3]. Im sure this is incredibly simple and im overlooking it but its driving me absolutely insane.

Answer 1

Here is my attempt to fix this problem. I left the reading cell values and writing results to the OP as I am focused on the logic of the process.

There are three main functions. DiceRollSim(), RollDie() and GetNLargestIndex() as well as a function to test the code, named Test().

DiceRollSim() runs the particular simulation given the number of sides, and number of die and the number to keep. It prints the results in the output window. DollDie() fills in an array of random values simulating the rolling of the die. Caution is needed to make sure the interval probabilities are maintained as VBA does round values when converting the result of Rnd() into integers. Finally, GetNLargestIndex() is the meat of the answer, as it takes the die roll results, creates an array of index values (the 1st, 2nd, 3rd .. ) and then sorts the array based on the values of the die rolls.

Option Explicit

Public Sub Test()
    DiceRollSim 6, 15, 3

    ' Example, 15k3:

    '    Rolling 15 die.
    '    x(1) = 5       *
    '    x(2) = 4
    '    x(3) = 4
    '    x(4) = 2
    '    x(5) = 4
    '    x(6) = 5       **
    '    x(7) = 6       ***
    '    x(8) = 1
    '    x(9) = 4
    '    x(10) = 3
    '    x(11) = 1
    '    x(12) = 3
    '    x(13) = 5
    '    x(14) = 3
    '    x(15) = 3

    '    Sorting die values.
    '    x(7) = 6
    '    x(6) = 5
    '    x(1) = 5
    '    Sum of 3 largest=16

End Sub

Public Sub DiceRollSim(ByVal n_sides As Long, ByVal n_dice As Long, ByVal n_keep As Long)

    Dim die() As Long, i As Long
    ReDim die(1 To n_dice)

    Debug.Print "Rolling " & n_dice & " die."
    Call RollDie(n_sides, n_dice, die)
    For i = 1 To n_dice
        Debug.Print "x(" & i & ")=" & die(i)
    Next i

    Dim largest() As Long

    Debug.Print "Sorting die values."
    Call GetNLargestIndex(die, n_keep, largest)

    Dim x_sum As Long
    x_sum = 0
    For i = 1 To n_keep
        x_sum = x_sum + die(largest(i))
        Debug.Print "x(" & largest(i) & ")=" & die(largest(i))
    Next i

    Debug.Print "Sum of " & n_keep & " largest=" & x_sum
End Sub

Public Sub RollDie(ByVal n_sides As Long, ByVal n_dice As Long, ByRef result() As Long)
    ReDim result(1 To n_dice)
    Dim i As Long
    For i = 1 To n_dice
        ' Rnd() resurns a number [0..1)
        ' So `Rnd()*n_sides` returns a floating point number zero or greater, but less then n_sides.
        ' The integer conversion `CLng(x)` rounds the number `x`, and thus will not keep equal
        ' probabilities for each side of the die.
        ' Use `CLng(Floor(x))` to return an integer between 0 and n_sides-1
        result(i) = 1 + CLng(WorksheetFunction.Floor_Math(Rnd() * n_sides))
    Next i
End Sub

Public Sub GetNLargestIndex(ByRef die() As Long, ByVal n_keep As Long, ByRef index() As Long)
    Dim n_dice As Long, i As Long, j As Long, t As Long
    n_dice = UBound(die, 1)

    ' Instead of sorting the die roll results `die`, we sort
    ' an array of index values, starting from 1..n
    ReDim index(1 To n_dice)
    For i = 1 To n_dice
        index(i) = i
    Next i

    ' Bubble sort the results and keep the top 'n' values
    For i = 1 To n_dice - 1
        For j = i + 1 To n_dice
            ' If a later value is larger than the current then
            ' swap positions to place the largest values early in the list
            If die(index(j)) > die(index(i)) Then
                'Swap index(i) and index(j)
                t = index(i)
                index(i) = index(j)
                index(j) = t
            End If
        Next j
    Next i

    'Trim sorted index list to n_keep
    ReDim Preserve index(1 To n_keep)

End Sub

Answer 2

Today I was watching some MonteCarlo simulations, so I have decided to do the whole question from the beginning. Thus, imagine that this is the input:

After the first roll, this is what you get:

The values in yellow are the top 3, which are kept. This is the result from the second roll:

And here is the whole code:

Public Sub RollMe()

    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))

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

The makeRandom and lastCol functions are some functions that I use for other projects as well:

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

Instead of looping through the array "manually", the WorksheetFunction.Large() nicely returns the Nth-largest value.

---

And if you are willing to color the "dice", which were used to take the top score, you may add this piece:

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

It produces this, coloring the top cells in Magenta:

---

Edit: I have even wrote an article using the code above in my blog here: vitoshacademy.com/vba-simulation-of-rolling-dices

Answer 3

Try this, changed a few things: Edited the random bit too

Private Sub CommandButton1_Click()

Dim i As Long, j As Long, k As Long
Dim RandNum As Long
Dim RollArray() As Long
Dim KeptArray() As Long
Dim NumRoll As Long
Dim Kept As Long

NumRoll = Range("B2").Value
ReDim RollArray(1 To NumRoll)

Kept = Range("C2").Value
ReDim KeptArray(1 To Kept)

For i = 5 To 15
    Randomize

    'RandNum = 1 + Rnd() * (Range("A2").Value - 1)
    RandNum = 1 + Int(Rnd() * Range("A2").Value)
    Cells(i, 1).Value = RandNum
Next i

For j = 1 To NumRoll
    RollArray(j) = Cells(4 + j, 1).Value
    Cells(4 + j, 2).Value = RollArray(j)
Next j


For k = 1 To Kept
    KeptArray(k) = Application.WorksheetFunction.Large(RollArray, k)
    Cells(4 + k, 3).Value = KeptArray(k)
Next k

End Sub

Makes use of the Excel large function