vba - 比较数组中的数字

问题描述

所以这个问题比简单的比较更深入。本质上，我试图模拟这种称为滚动和保持系统的掷骰子。例如 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]。我确信这非常简单，我忽略了它，但它让我绝对发疯。

标签： vbaexcel

解决方案

今天我在看一些蒙特卡洛模拟，所以我决定从头开始做整个问题。因此，假设这是输入：

第一次滚动后，您会得到：

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

这是整个代码：

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

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

如果您愿意为用于获得最高分的“骰子”上色，您可以添加以下内容：

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

vba - 比较数组中的数字

问题描述

解决方案

推荐阅读