Function RandLen(dTot As Double, _
Optional dMin As Double = 0#, _
Optional ByVal iSig As Long = 0, _
Optional bVolatile As Boolean = False) As Double()
' shg 2011, 2013
' UDF wrapper for adRandLen
Dim adTmp() As Double
Dim adOut() As Double
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
adTmp = adRandLen(dTot, nRow * nCol, dMin, iSig)
ReDim adOut(1 To nRow, 1 To nCol)
For iRow = 1 To nRow
For iCol = 1 To nCol
adOut(iRow, iCol) = adTmp((iRow - 1) * nCol + iCol)
Next iCol
Next iRow
RandLen = adOut
End Function
Function adRandLen(ByVal dTot As Double, _
nOut As Long, _
Optional ByVal dMin As Double = 0#, _
Optional ByVal iSig As Long = 307) As Double()
' shg 2011
' Applies string-cutting to return an array of nOut
' numbers totalling dTot, with each in the range
' dMin <= number <= Round(dTot, iSig) - nOut * round(dMin, iSig)
' Each number is rounded to iSig decimals
Dim iOut As Long ' index to iOut
Dim jOut As Long ' sort insertion point
Dim dRnd As Double ' random number
Dim dSig As Double ' decimal significance (e.g., 1, 0.01, ...)
Dim adOut() As Double ' output array
dTot = WorksheetFunction.Round(dTot, iSig)
dMin = WorksheetFunction.Round(dMin, iSig)
If nOut < 1 Or dTot < nOut * dMin Then Exit Function
ReDim adOut(1 To nOut)
dSig = 10# ^ -iSig
With New Collection
.Add Item:=0#
.Add Item:=dTot - nOut * dMin
' create the cuts
For iOut = 1 To nOut - 1
dRnd = Int(Rnd() * ((dTot - nOut * dMin) / dSig)) * dSig
' insertion-sort the cut
For jOut = .Count To 1 Step -1
If .Item(jOut) <= dRnd Then
.Add Item:=dRnd, After:=jOut
Exit For
End If
Next jOut
Next iOut
' measure the lengths
For iOut = 1 To nOut
adOut(iOut) = .Item(iOut + 1) - .Item(iOut) + dMin
Next iOut
End With
adRandLen = adOut
End Function
I need each of those rows to equal a specific number all the way accross.
