Question

我正在尝试在Excel工作表中实现随机数生成。过程如下：

有七个单元格，每个单元格包含要以标准符号滚动的骰子的数量和类型（XdY + Z，其中X是要滚动的Y面骰子的数量，Z是奖励/惩罚）
数字按卷类型计算为唯一的组
为每个组生成数字（我已执行此步骤，因此这不是问题所在。）
为每组制作一次额外的滚动
最低号码被删除
数字按顺序分配到输出范围，因此它们与骰子行匹配。

我知道我可以使用集合从输入中提取唯一值。我还有一个函数可以解释骰子类型并进行滚动。我虽然能够计算出唯一值，但是多次滚动+ 1，降低最低值然后将它们返回到正确的行，我感到困惑。特别是因为我不想对结果进行排序。

如果您有任何帮助或任何方向可以指出我，我将不胜感激。

示例：

Input:   

1d6    
1d6    
1d8    
1d10    
1d4    
1d6   
1d4    

Divide into buckets: 3 x 1d6; 1 x 1d8; 1 x 1d10; 2 x 1d4    

Roll dice, with an extra roll for each bucket:    
4 x 1d6 - 4, 4, 5, 2    
2 x 1d8 - 8, 7    
2 x 1d10 - 1, 3    
3 x 1d4 - 1, 1, 4    

Drop lowest value, leaving the following numbers:    
1d6: 4, 4, 5    
1d8: 8    
1d10: 3    
1d4: 1, 4    

Assign them in order:    
1d6 - 4   
1d6 - 4    
1d8 - 8    
1d10 - 3    
1d4 - 1    
1d6 - 5    
1d4 - 4

这是原始函数，它只是在列表中，生成滚动（通过执行滚动的RollDice函数），并将其放在正确的输出单元格中：

Sub GenerateOld()
    For i = 1 To 7
        Range("Dice_Output").Cells(i).Value = _
            RollDice(Range("Dice_Input").Cells(i).Value)
    Next i
End Sub

这是我尝试使用此版本的新版本。注释掉的是我无法弄清楚的部分：

Sub GenerateNew()
    Dim diceDictionary
    Set diceDictionary = CreateObject("Scripting.Dictionary")

    For Each Cell In Range("Char_Characteristics_Dice").Cells
        If diceDictionary.Exists(Cell.Value) Then
            diceDictionary(Cell.Value) = diceDictionary(Cell.Value) + 1
        Else
            diceDictionary.Add Cell.Value, 1
        End If
    Next Cell

    For Each diceType In diceDictionary
        ' RollDice(diceType)
        ' Roll X drop lowest
    Next cont

    ' Place back into Dice_Output range in order
End Sub

Answer 1

不确定是否还需要这个，但我使用了一组数组来解决这个问题。以下是我如何处理它的摘要：

从Excel中的范围中获取值，将它们传递给第一个数组
设置需要掷骰子的次数
将第一个数组传递给2D数组并使用info填充它以完成

使用临时数组从卷中获取值，然后粘贴回Excel工作表

Sub roll()

Dim i As Long
Dim j As Long
Dim k As Long
Dim lr As Long

Dim upperbound As Long
Dim lowerbound As Long
Dim frequency As String
Dim rolls As String

Dim rng As Range
Dim arr1D() As String
Dim arr2D() As String
Dim rollresult As Integer

Dim arr_min As Variant
Dim FirstCheck As Boolean
Dim targetdi As Variant

'Set the area with values for the dice roll simulation
lr = Cells(Rows.Count, "A").End(xlUp).Row

'Clear the result area for roll results
Range(Cells(2, "B"), Cells(lr, "B")).ClearContents

Set rng = Range(Cells(2, "A"), Cells(lr, "A"))

'Collect unique values from the range
For Each cell In rng
    If (cell <> "") And (InStr(frequency, cell) = 0) Then
        frequency = frequency & cell & "|"
    End If
Next cell
If Len(frequency) > 0 Then frequency = Left(frequency, Len(frequency) - 1)
arr1D = Split(frequency, "|")

    'Set up the 2D array with a space for the number of rolls
    ReDim arr2D(LBound(arr1D) To UBound(arr1D), LBound(arr1D) To 3)

        'Copy contents from first (1D) array into the second (2D) array
    For i = LBound(arr1D) To UBound(arr1D)
        arr2D(i, 0) = arr1D(i)
        arr2D(i, 1) = Application.WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(lr, "A")), "=" & arr2D(i, 0)) + 1
        arr2D(i, 2) = Right(arr2D(i, 0), Len(arr2D(i, 0)) - InStr(1, arr2D(i, 0), "d"))

    'Keep rollin rollin rollin WHAT Keep rollin rollin rollin
        For j = 1 To (arr2D(i, 1))
            If ((arr2D(i, 2)) <> "") Then
                rollresult = Int((Int((arr2D(i, 2) + 1)) - 1 + 1) * Rnd + 1)
                rolls = rolls & rollresult & "|"
            End If
        Next j
    rolls = Left(rolls, Len(rolls) - 1)
    arr2D(i, 3) = rolls
    rolls = ""
    Next i

For i = LBound(arr2D) To UBound(arr2D)
    temparray = Split(arr2D(i, 3), "|")
    arr_min = temparray(LBound(temparray))
        For j = LBound(temparray) To UBound(temparray) 'LBound(temparray) To UBound(temparray) - 1
            If temparray(j) < arr_min Then
                arr_min = temparray(j)
            End If
        Next j

'Remove the lowest value, but preserve the order
    For j = LBound(temparray) To UBound(temparray)
        If temparray(j) = arr_min And FirstCheck = False Then
            temparray(j) = ""
            FirstCheck = True
        End If
    Next j

'Place the results back in the sheet
For j = LBound(temparray) To UBound(temparray)
    If temparray(j) <> "" Then
        targetdi = arr2D(i, 0)
            For k = 2 To lr
                If Cells(k, "A").Value = targetdi And Cells(k, "B").Value = "" Then
                    Cells(k, "B").Value = temparray(j)
                End If
            Next k
        End If
    Next j

Next i

End Sub

VBA：为范围的唯一值生成数字并将它们返回到范围（模拟骰子卷）

1 个答案: