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

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

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