Option Explicit
Public DataARR As Variant
Function Fu_SortARR(ByVal DataVAR As Variant, Optional CoINT As Integer) As Variant
Dim RowsARR As Variant, ReturnARR As Variant
Dim i As Long, j As Long, DataLNG As Long
DataARR = DataVAR
DataLNG = UBound(DataARR, 1)
ReDim RowsARR(1 To DataLNG)
For i = DataLNG To 1 Step -1
RowsARR(i) = i
Next i
ReDim ReturnARR(1 To DataLNG, 1 To UBound(DataARR, 2))
For i = 1 To DataLNG
For j = 1 To UBound(ReturnARR, 2)
ReturnARR(i, j) = DataARR(RowsARR(i), j)
Next j
Next i
Fu_SortARR = ReturnARR
End Function
Function Fu_Fill_RNG(SrcRNG As Range, FillRows As Long, Optional DstRNG As Range, Optional NoRepetion As Boolean = False, Optional There_is_Headers As Boolean = False) As Variant
On Error GoTo ErrHand: Application.Calculation = xlManual: Application.ScreenUpdating = False: Application.DisplayAlerts = False: Dim coT As Single: coT = Timer() ' Timer start
'Dim wb As Workbook, wsR As Worksheet, wsW As Worksheet
Dim i As Long, j As Long, iR As Long, iRt As Long, SrcARRSum As Long, SeaSNG As Single, TrgSNG As Single, Fill_Values As Long
Dim SrcARR As Variant, DstARR() As Variant, FillARR As Variant
'Dim TrueCounter As Long ' Only for Debuging
If There_is_Headers Then Set SrcRNG = SrcRNG.Offset(1, 0).Resize(SrcRNG.Rows.Count - 1, SrcRNG.Columns.Count)
If NoRepetion And FillRows > Application.Sum(SrcRNG.Columns(2)) Then FillRows = Application.Sum(SrcRNG.Columns(2))
Fill_Values = SrcRNG.Rows.Count
ReDim FillARR(1 To FillRows, 1 To 1) ' Fit FillARR for return values
'Dim TestARR As Variant: ReDim TestARR(1 To FillRows, 1 To 1) ' Fit TestARR for randomed values, only for test/debuging
Randomize
If SrcRNG.Columns.Count = 1 Then ' No Probability calculated, ALL VALUES HAVE EQUAL PROBABILITY!
SrcARR = SrcRNG.value
For i = LBound(FillARR) To UBound(FillARR)
TrgSNG = Application.RoundDown(Rnd() * Fill_Values + 1, 0)
FillARR(i, 1) = SrcARR(TrgSNG, 1)
' TestARR(i, 1) = TrgSNG ' Only for Debuging
Next i
ElseIf SrcRNG.Columns.Count = 2 Then ' Probability numbers found from column(2) calculating probabilities, ALL VALUES HAVE OWN PROBABILITY!
ReDim DstARR(1 To SrcRNG.Rows.Count, 1 To 4) ' Values and frequensy
SrcRNG.Sort Key1:=SrcRNG.Cells(1, 2), Order1:=xlAscending ' SORTING SOURCE RANGE!
SrcARR = SrcRNG.value ' Source Range to Array
' Summing all occurrences from Columns(2) for counting probabilities.
With Application.WorksheetFunction
SrcARRSum = .Sum(.Index(SrcARR, 0, 2))
End With
'***** Filling DstARR with SrcARR values AND adding probabilities.
For i = LBound(SrcARR) To UBound(SrcARR)
For j = LBound(SrcARR, 2) To UBound(SrcARR, 2)
DstARR(i, j) = SrcARR(i, j)
DstARR(i, j + 1) = Round(CSng(DstARR(i, 2) / SrcARRSum), 5)
DstARR(i, j + 2) = Round(CSng(Application.Sum(Application.Index(DstARR, 0, 3))), 4)
Next j
Next i
If Not NoRepetion Then
'***** RANDOMING FILL VALUES! ***********************************************************************
For i = LBound(FillARR) To UBound(FillARR)
TrgSNG = Rnd()
' TestARR(i, 1) = TrgSNG ' Only for Debuging
For j = LBound(DstARR) To UBound(DstARR)
SeaSNG = DstARR(j, 4)
If SeaSNG > TrgSNG Then
FillARR(i, 1) = DstARR(j, 1)
Exit For
End If
Next j
Next i
Else
For i = LBound(FillARR) To UBound(FillARR)
TrgSNG = Rnd()
'TestARR(i, 1) = TrgSNG ' Only for Debuging
For j = LBound(DstARR) To UBound(DstARR)
SeaSNG = DstARR(j, 4)
If DstARR(j, 4) > TrgSNG And 0 < DstARR(j, 2) Then
'TrueCounter = TrueCounter + 1 ' Only for Debuging
FillARR(i, 1) = DstARR(j, 1)
DstARR(j, 2) = DstARR(j, 2) - 1
SrcARRSum = Application.Sum(Application.Index(DstARR, 0, 2))
For iR = LBound(DstARR) To UBound(DstARR)
If DstARR(iR, 2) = 0 Then
DstARR(iR, 3) = 0
Else
DstARR(iR, 3) = Round(CSng(DstARR(iR, 2) / SrcARRSum), 5)
End If
Next iR
DstARR = Fu_SortARR(DstARR, 3)
For iR = LBound(DstARR) To UBound(DstARR)
DstARR(iR, 4) = 0
For iRt = LBound(DstARR) To iR
DstARR(iR, 4) = DstARR(iR, 4) + DstARR(iRt, 3)
Next iRt
DstARR(iR, 4) = Round(DstARR(iR, 4), 4)
Next iR
Exit For
End If
Next j
Next i
End If
Else
End
End If
'***** Selecting if return value are written directly to range or given as Function Return value ***********
If Not DstRNG Is Nothing Then
DstRNG.Resize(FillRows, 1).value = FillARR
Fu_Fill_RNG = True
Else
Fu_Fill_RNG = FillARR
End If
' Test and Debug value
'Taul3.Range("L2").Resize(UBound(TestARR) - 1, 1).value = TestARR
ErrHand:
Application.Calculation = xlAutomatic: Application.ScreenUpdating = True: Application.DisplayAlerts = True
If Err.Number <> 0 Then MsgBox "Something went badly wrong!" & vbCrLf & "Function Fu_Fill_RNG FAILED!!!" & vbCrLf & "VBA-code is ended!" & vbCrLf & vbCrLf & "Error number: " & Err.Number & " " & Err.Description: End
End Function
Sub Use_Fu_Fill_RNG()
Dim x As Variant, x2 As Variant, FillRows As Long, SourceRNG As Range, DestinationRNG As Range
Dim coT As Single: coT = Timer() ' Timer start
Dim TEST As Variant
'********** INSTRUCTIONS *************************************************************************************
'* If DestinationRNG is not defined, function "Fu_Fill_RNG" return ARRAY of values to x !
'* If DestinationRNG is defined, function "Fu_Fill_RNG" write values DIRECTLY to DestinationRNG.
'* Return value to x is then Type: Boolean True/False (True=No Errors, False = Errors function FAILED!
'* If SourceRNG is 1 Column then all VALUES ARE SELECTED RANDOMLY with EQUAL POSIBILITIES _
'* if SourceRNG is 2 Column, Second Column must contain NUMBER OF POSIBILITIES (how many of each value there are) _
'* Function count posibilities by NUMBER OF POSIBILITIES (The dice have 6 "Value" and each have 1 "NUMBER OF POSSIBILITIES")
'* Dice "Col A" "Col B"
'* 1 1
'* 2 1
'* 3 1
'* 4 1
'* 5 1
'* 6 1
'**************************************************************************************************************
' Example data set start
Dim tmpARR(1 To 5, 1 To 2) As Long
tmpARR(1, 1) = 1: tmpARR(1, 2) = 2 ' 2/17
tmpARR(2, 1) = 2: tmpARR(2, 2) = 5 ' 5/17
tmpARR(3, 1) = 3: tmpARR(3, 2) = 3 ' 3/17
tmpARR(4, 1) = 4: tmpARR(4, 2) = 1 ' 1/17
tmpARR(5, 1) = 5: tmpARR(5, 2) = 6 ' 6/17
If Worksheets(1).Range("A2") = "" Then
Worksheets(1).Range("A2:B6").Value2 = tmpARR
End If
' Example data set end
'********** PARAMETERS FOR "Fu_Fill_RNG" FILL WANTED VALUES HERE! *********************************************
FillRows = 100 ' How many Cells(rows) to Fill? (How many draws)
Set SourceRNG = Worksheets(1).Range("A2:B6") ' Where Found Values to Draw? (Col A= random numbers, Col B = weights (How many times each number is there?) (count of each number/count of all numbers = weights like 27/147)
Set DestinationRNG = Worksheets(1).Range("F1") ' What Column will be Filled? Only First Cell address
'********** PARAMETERS END! ***********************************************************************************
x = Fu_Fill_RNG(SourceRNG, FillRows, DestinationRNG, False)
Debug.Print Format(Timer() - coT, "#0.00", 2)
End Sub
