VBA：爲範圍的唯一值生成數字並將它們返回到範圍（模擬骰子卷）

Question

我試圖在Excel工作表中實現隨機數生成。該過程是這樣的：

1. 有七個單元，每個單元含有在標準符號（XDY + Z，其中X是對卷的Y面骰子的數目被軋製，以Z骰子的數量和類型作爲獎金/罰分）
2. 的號碼被通過輥類型
3. 的數字是爲每個組（I有這一步工作，所以這是沒有問題的）中產生總結了成唯一的組。
4. 一個附加輥對每個組
5. 的最低數目被丟棄
6. 的號碼被分配到輸出範圍中，爲了製成，所以它們匹配他們的骰子的行。

我知道我可以使用集合從我的輸入中提取唯一值。我也有一個解釋骰子類型並進行翻滾的功能。儘管我能夠計算出獨特的價值，但我很難過，多次滾動+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

不知道這仍然是需要的，但我用一組陣列來解決這個問題。下面是我如何走近它的摘要：

1. 從Excel的範圍內獲取的值，它們傳遞到第一陣列
2. 設置的次數需要進行擲骰子
3. 傳第一陣列的2D陣列，並用信息填充它完成

4. 使用臨時數組以得到從輥值，然後粘貼到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