Option Explicit
Public Const sRng As String = "Sheet1!A1:A4"
Public Const iTot As Long = 52
Public Const iMin As Long = 1
Sub HikerChange(Target As Range)
Dim rInt As Range
Dim adCal() As Double
Dim i As Long
Dim cell As Range
If Not Target.Worksheet Is Range(sRng).Worksheet Then Exit Sub
Set rInt = Intersect(Target, Range(sRng))
If rInt Is Nothing Then Exit Sub
If rInt.Cells.Count > 1 Then Exit Sub
On Error GoTo Oops
Application.EnableEvents = False
If iTot - WorksheetFunction.Sum(rInt) < iMin * Range(sRng).Cells.Count Then
For Each cell In Range(sRng)
If cell.Address <> rInt.Address Then
cell.Value2 = "Oops!"
End If
Next cell
Else
adCal = aiRandLen(dTot:=iTot - rInt.Value2, _
nNum:=Range(sRng).Cells.Count - 1, _
dMin:=iMin, _
iSig:=0)
For Each cell In Range(sRng)
If cell.Address <> rInt.Address Then
i = i + 1
cell.Value2 = adCal(i)
End If
Next cell
End If
Oops:
Application.EnableEvents = True
End Sub
Function aiRandLen(ByVal dTot As Double, _
nNum 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 nNum
' numbers totalling dTot, with each in the range
' dMin <= number <= Round(dTot, iSig) - nNum * round(dMin, iSig)
' Each number is rounded to iSig decimals
Dim i As Long
Dim j As Long
Dim dRnd As Double
Dim dSig As Double
Dim col As Collection
Dim adOut() As Double
dTot = WorksheetFunction.Round(dTot, iSig)
dMin = WorksheetFunction.Round(dMin, iSig)
If nNum < 1 Or dTot < nNum * dMin Then Exit Function
ReDim adOut(1 To nNum)
dSig = 10 ^ -iSig
With New Collection
.Add Item:=0
.Add Item:=dTot - nNum * dMin
' create the cuts
For i = 1 To nNum - 1
dRnd = Int(Rnd * ((dTot - nNum * dMin) / dSig)) * dSig
' insertion-sort the cut
For j = .Count To 1 Step -1
If .Item(j) <= dRnd Then
.Add Item:=dRnd, After:=j
Exit For
End If
Next j
Next i
' measure the lengths
For i = 1 To nNum
adOut(i) = .Item(i + 1) - .Item(i) + dMin
Next i
End With
aiRandLen = adOut
End Function
