Function RandLen(iTot As Long, _
Optional iMin As Long = 0&, _
Optional iMax As Long = 2147483647, _
Optional bDist As Boolean = False, _
Optional bVolatile As Boolean = False) As Long()
' shg 2011, 2018 (added iMax)
' UDF wrapper for aiRandLenMinMax
Dim aiTmp() As Long
Dim aiOut() As Long
Dim iRow As Long
Dim nRow As Long
Dim iCol As Long
Dim nCol As Long
If bVolatile Then Application.Volatile
nRow = Application.Caller.Rows.Count
nCol = Application.Caller.Columns.Count
aiTmp = aiRandLenMinMax(iTot, nRow * nCol, iMin, iMax, bDist)
ReDim aiOut(1 To nRow, 1 To nCol)
For iRow = 1 To nRow
For iCol = 1 To nCol
aiOut(iRow, iCol) = aiTmp((iRow - 1) * nCol + iCol)
Next iCol
Next iRow
RandLen = aiOut
End Function
Function aiRandLenMinMax(ByVal iTot As Long, _
k As Long, _
Optional ByVal iMin As Long = 0&, _
Optional ByVal iMax As Long = 2147483647, _
Optional bDist As Boolean = False) As Long()
' shg 2018
' VBA only
Dim ai() As Long ' initially cuts, and then lengths
Dim i As Long
Dim iCut As Long
Dim iTmp As Long
If k < 1 Then Exit Function
If iMin < 0 Then iMin = 0
If iTot < k * iMin Then Exit Function
If iMax < iTot \ k Then Exit Function
If iMax > iTot Then iMax = iTot
iTot = iTot - k * iMin ' accommodate min
If bDist Then iTot = iTot - k * (k - 1&) \ 2& ' accommodate distinct
ReDim ai(1 To k + 1)
' make cuts at intervals that ensure values w/in max
For i = 0& To iTot Step iMax - iMin - IIf(bDist, k - 1&, 0&)
iCut = iCut + 1&
ai(iCut) = i
Next i
' there must be a cut at the top of the string
If ai(iCut) <> iTot Then
iCut = iCut + 1&
ai(iCut) = iTot
End If
' make the rest of the cuts
For iCut = iCut + 1& To k + 1&
ai(iCut) = Int(Rnd() * (iTot + 1&))
Next iCut
' sort the cuts and measure the lengths between
InsertionSort ai
For i = 1 To k
iTmp = ai(i)
ai(i) = ai(i + 1&) - iTmp + iMin
Next i
' get rid the the extra entry
ReDim Preserve ai(1& To k)
If bDist Then
InsertionSort ai
For i = 1 To k
ai(i) = ai(i) + i - 1&
Next i
FYShuffle1D ai
End If
aiRandLenMinMax = ai
End Function
Function InsertionSort(ByRef av As Variant) As Boolean
' Sorts 1D or 2D array av in situ; if 2D, one dimension must be 1
Dim iLB As Long
Dim iUB As Long
Dim LB As Long
Dim i As Long
Dim j As Long
Dim v As Variant
Select Case NumDim(av)
Case 0, Is > 2
' not an array, or > 2 dimensions
Case 1
iLB = LBound(av)
iUB = UBound(av)
For i = iLB + 1 To iUB
v = av(i)
For j = i - 1 To iLB Step -1
If av(j) <= v Then Exit For
av(j + 1) = av(j)
Next j
av(j + 1) = v
Next i
InsertionSort = True
Case 2
If UBound(av, 1) - LBound(av, 1) > 0 Then
If UBound(av, 2) - LBound(av, 2) > 0 Then Exit Function
iLB = LBound(av, 1)
iUB = UBound(av, 1)
LB = LBound(av, 2)
For i = iLB + 1 To iUB
v = av(i, LB)
For j = i - 1 To iLB Step -1
If av(j, LB) <= v Then Exit For
av(j + 1, LB) = av(j, LB)
Next j
av(j + 1, LB) = v
Next i
InsertionSort = True
Else
iLB = LBound(av, 2)
iUB = UBound(av, 2)
LB = LBound(av, 1)
For i = iLB + 1 To iUB
v = av(LB, i)
For j = i - 1 To iLB Step -1
If av(LB, j) <= v Then Exit For
av(LB, j + 1) = av(LB, j)
Next j
av(LB, j + 1) = v
Next i
InsertionSort = True
End If
End Select
End Function
Sub FYShuffle1D(av As Variant)
' shg 2015
' In-situ Fisher-Yates shuffle of 1D array av
' VBA only
Dim iLB As Long
Dim iTop As Long
Dim vTmp As Variant
Dim iRnd As Long
iLB = LBound(av)
iTop = UBound(av) - iLB + 1
Do While iTop
iRnd = Int(Rnd * iTop)
iTop = iTop - 1
vTmp = av(iTop + iLB)
av(iTop + iLB) = av(iRnd + iLB)
av(iRnd + iLB) = vTmp
Loop
End Sub
