Sub TestDecimalWeights()
'
Dim ClearPreviousResults As Boolean
Dim SumOfWeights As Double
Dim ArrayRow As Long, WeightRow As Long
Dim RowCount As Long, RunCount As Long
Dim ColumnNumber As Long, InnerColumnNumber As Long
Dim Iterations As Long, Multiplier As Long
Dim RandomInteger As Long, SumOfIntegers As Long
Dim Dict As Object
Dim ActualPercentageColumn As String, LookupValueResultsColumn As String, TallyStringColumn As String
Dim WeightLastColumn As String, WeightStartColumn As String
Dim LookupValueResultColumnStartAddress As String, MultiplierAddress As String, RunCountAddress As String
Dim LookupValueString As String, TallyString As String
Dim IntegerArray As Variant, WeightArray As Variant
Dim LookupArray As Variant, PercentExpectedArray As Variant, TallyPercentArray As Variant
'
ClearPreviousResults = False ' <--- Set this to True if you want clear the previous results each time, otherwise False
WeightRow = 6 ' <--- Set this to the row # that the weights will be stored on
LookupValueResultsColumn = "B" ' <--- Set this to the column to display the LookupValueResults
TallyStringColumn = "C" ' <--- Set this to the column letter to display the TallyString into
ActualPercentageColumn = "D" ' <--- Set this to the column to display the ActualPercentages received to
WeightStartColumn = "D" ' <--- Set this to the column letter that the weights will start on
LookupValueResultColumnStartAddress = "B12" ' <--- Set this to the start address of the LookupValueResults
MultiplierAddress = "D7" ' <--- Set this to the address of the Multiplier
RunCountAddress = "C3" ' <--- Set this to the column that contains the # of iterations to execute
'
'-------------------------------------------------------------------------------------------------------
'
' Gather data needed from the sheet
Iterations = Range(RunCountAddress).Value ' Get the # of iterations
Multiplier = Range(MultiplierAddress).Value ' Get the Multiplier value
'
WeightLastColumn = Split(Cells(Rows(WeightRow).Find("*", , xlFormulas, , xlByColumns, _
xlPrevious).Column).Address, "$")(1) ' Calculate the column letter of the last weight on the sheet
'
WeightArray = Range(WeightStartColumn & WeightRow & ":" & WeightLastColumn & WeightRow) ' Save the weights into 2D 1 Based WeightArray
'
'-------------------------------------------------------------------------------------------------------
'
' Establish some arrays that will be needed
ReDim IntegerArray(1 To UBound(WeightArray, 1), 1 To UBound(WeightArray, 2)) ' Set IntegerArray to the same dimensions as WeightArray
ReDim TallyPercentArray(1 To UBound(WeightArray, 1), 1 To UBound(WeightArray, 2)) ' Set TallyPercentArray to the same dimensions as WeightArray
ReDim PercentExpectedArray(1 To UBound(WeightArray, 1), 1 To UBound(WeightArray, 2)) ' Set PercentExpectedArray to the same dimensions as WeightArray
'
' Convvert the weights to integer equivalent, Sum the weights, Sum the integer equivalents
For ColumnNumber = 1 To UBound(WeightArray, 2) ' Loop through the weights
IntegerArray(1, ColumnNumber) = Round(WeightArray(1, ColumnNumber) * Multiplier, 0) ' Convert the weight to an integer & save it into IntegerArray
SumOfWeights = SumOfWeights + WeightArray(1, ColumnNumber) ' Add the weight to SumOfWeights
SumOfIntegers = SumOfIntegers + IntegerArray(1, ColumnNumber) ' Add the integer to SumOfIntegers
Next ' Loop back
'
' Calculate the expected percentages
For ColumnNumber = 1 To UBound(WeightArray, 2) ' Loop through the weights
PercentExpectedArray(1, ColumnNumber) = WeightArray(1, ColumnNumber) / SumOfWeights ' Calculate the percent expected & save it into PercentExpectedArray
Next
'
' Write the integer equivalents to the sheet, Write the expected percentages to the sheet
Range(WeightStartColumn & WeightRow).Offset(2).Resize(UBound(IntegerArray, 1), _
UBound(IntegerArray, 2)) = IntegerArray ' Write the integers to the sheet
Range(WeightStartColumn & WeightRow).Offset(3).Resize(UBound(PercentExpectedArray, 1), _
UBound(PercentExpectedArray, 2)) = PercentExpectedArray ' Write the PercentExpectedArray to the sheet
'
'-------------------------------------------------------------------------------------------------------
'
' Create the LookupArray, This will be a 'weighted' array of x amount of 1's, x amount of 2's, x amount of 3's, etc.
ReDim LookupArray(1 To SumOfIntegers, 1 To 1) ' Establish the row/column size of LookupArray
'
' RowCount = 0 ' Initialize RowCount
'
For ColumnNumber = 1 To UBound(IntegerArray, 2) ' Loop through columns of IntegerArray ... 1 to 5 for example
For InnerColumnNumber = 1 To IntegerArray(1, ColumnNumber) ' Loop to add loops of values to add to LookupArray
RowCount = RowCount + 1 ' Increment RowCount
'
LookupArray(RowCount, 1) = ColumnNumber ' Save ColumnNumber to LookupArray
Next ' Loop back
Next ' Loop back
'
'-------------------------------------------------------------------------------------------------------
'
' Get results
LookupValueString = "" ' Initialize LookupValueString
'
Set Dict = CreateObject("Scripting.Dictionary") ' Establish the dictionary we will use
'
Randomize ' Randomize the random number generator
'
If ClearPreviousResults Then
Range(LookupValueResultColumnStartAddress & ":" & Split(Cells(Cells.Find("*", , xlFormulas, , _
xlByColumns, xlPrevious).Column).Address, "$")(1) & Cells.Find("*", , xlFormulas, , _
xlByRows, xlPrevious).Row).ClearContents ' Clear previous results
End If
'
' PreLoad Dictionary values to expect
For ArrayRow = 1 To UBound(IntegerArray, 2) ' Loop through columns of IntegerArray
Dict.Add ArrayRow, 0 ' Initalize Key and Item
Next ' Loop back
'
' Calculate random integer, save the random integer to LookupValueString, increment the counter for that random integer in the dictionary
For RunCount = 1 To Iterations ' Loop to get # of results determined by RunCountAddress value
RandomInteger = Int((UBound(LookupArray, 1) - LBound(LookupArray, 1) _
+ 1) * Rnd + 1) ' Calculate a random integer between 1 & MaxArrayRowSize
'
LookupValueString = LookupValueString & LookupArray(RandomInteger, 1) & " " ' Save the lookup value to LookupValueString
'
Dict.Item(LookupArray(RandomInteger, 1)) = _
Dict.Item(LookupArray(RandomInteger, 1)) + 1 ' Increment the count of that Lookup value in the dictionary
Next ' Loop back
'
' Save the tally counts to TallyString, Calculate the percentage those tally counts represent & save into TallyPercentArray
For ArrayRow = 0 To Dict.Count - 1 ' Loop through the Tally values in the dictionary
TallyString = TallyString & Dict.Items()(ArrayRow) & " " ' Save the counter for the Lookup value to TallyString
TallyPercentArray(1, ArrayRow + 1) = Format(Dict.Items()(ArrayRow) / Iterations, "0.0%") ' Save tally percentage into TallyPercentArray
Next ' Loop back
'
' Display the LookupValueString, TallyString, & TallyPercentArray to the sheet
Range(LookupValueResultsColumn & Range(LookupValueResultsColumn & _
Rows.Count).End(xlUp).Row + 1) = Trim(LookupValueString) ' Display the LookupValueString to the sheet
Range(TallyStringColumn & Range(TallyStringColumn & _
Rows.Count).End(xlUp).Row + 1) = Trim(TallyString) ' Display the TallyString to the sheet
Range(ActualPercentageColumn & Range(ActualPercentageColumn & _
Rows.Count).End(xlUp).Row + 1).Resize(UBound(TallyPercentArray, 1), _
UBound(TallyPercentArray, 2)) = TallyPercentArray ' Display the TallyPercentArray to the sheet
'
' Autofit the width of the columns on the sheet
ActiveSheet.UsedRange.EntireColumn.AutoFit ' Autofit the width of the used columns
End Sub
