Question

所以这个问题比简单的比较更深入。基本上我试图模拟这个骰子卷，称为滚动和保持系统。例子是5k3。在哪里我会掷5个骰子并保持3个最高，然后将它们加在一起。

我已经得到了我的小宏程序来掷骰子。然后我将它们放在我的示例中的数组中，该数组将是一个包含5个索引的数组。现在我需要拿这5个骰子，并且只保留其中最大的3个。

代码在这里A2给了我骰子上的边数，B2给了我多少卷，C2给了我多少钱。这会掷10个骰子，但随后我将其中的5个转移到我的实际骰子中。我知道我可以跳过这个，但我可以稍后处理。

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

我尝试了很多东西，比如创建一个虚拟数组，并将变量Largest与它进行比较。还有很多其他的东西。我的大问题是我不能重复使用任何数字。

如果我滚动5并保持3.说我滚[4,2,3,3,6]。我保留[6,4,3]。我敢肯定这是非常简单，我忽略它，但它驱使我绝对疯了。

Answer 1

今天我正在观看一些MonteCarlo模拟，所以我决定从一开始就完成整个问题。因此，想象一下这是输入：

第一次滚动后，这就是你得到的：

黄色的值是前三个，保留。这是第二次滚动的结果：

以下是整个代码：

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

makeRandom和lastCol函数也是我用于其他项目的一些函数：

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

而不是循环遍历数组＆＃34;手动＆＃34;，WorksheetFunction.Large()很好地返回第N个最大值。

如果你愿意为那些用来获得最高分的＆＃34;骰子＆＃34;上色，你可以添加这篇文章：

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

它产生这个，使洋红色的顶部细胞着色：

编辑：我甚至在我的博客中使用上面的代码写了一篇文章： vitoshacademy.com/vba-simulation-of-rolling-dices

Answer 2

试试这个，改变了一些事情：也编辑了随机位

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

使用Excel大功能

Answer 3

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

比较数组中的数字

3 个答案: