Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.
Sub GetRandom()
Dim sht As Worksheet, dblSum As Double, cl As range
application.screenupdating=false
Const lgTarget As Long = 40
Const lgNumbers As Long = 6
Set sht = ActiveWorkbook.Sheets.Add
With range("A1:A" & lgNumbers)
.FormulaR1C1 = "=rand()"
.Value = .Value
dblSum = application.WorksheetFunction.Sum(range("A1:A" & lgNumbers))
For Each cl In .Cells
cl.Value = Round((cl.Value * lgTarget / dblSum), 0)
Next
.Cells(lgNumbers, 1).Value = lgTarget - application.WorksheetFunction.Sum(range("A1:A" & lgNumbers - 1))
End With
application.screenupdating=true
End Sub
intNumberToSumTo = 40
intNumbersRequired = 6
intLowerLimit = 1
intUpperLimit = intNumberToSumTo
strNumbers = ""
Randomize
For intNum = 1 To intNumbersRequired
intUpperLimit = intUpperLimit - (intNumbersRequired + 1 - intNum)
intNumber = Int((intUpperLimit - intLowerLimit) * Rnd + intLowerLimit)
intUpperLimit = (intUpperLimit + (intNumbersRequired + 1 - intNum)) - intNumber
If strNumbers = "" Then
strNumbers = intNumber
Else
strNumbers = strNumbers & "," & intNumber
End If
Next
MsgBox strNumbers
Sub Test()
MsgBox DoRand(30)
End Sub
Function DoRand(intNumber)
Randomize
intRemain = intNumber
strList = ""
While intRemain > 0
intNext = Int((intRemain * Rnd) + 1)
intRemain = intRemain - intNext
If strList = "" Then
strList = intNext
Else
strList = strList & "," & intNext
End If
Wend
DoRand = strList
End Function
~bp
Option Explicit
Private Sub CommandButton1_Click()
Dim randomSet As Variant
randomSet = RandomSumSet(40, 6)
' ...do something with the set...
ListBox1.Clear
Dim i As Integer
For i = LBound(randomSet) To UBound(randomSet)
ListBox1.AddItem randomSet(i)
Next
End Sub
Private Function RandomSumSet(ByVal sum As Integer, ByVal numDigits As Integer) As Variant
Static Seeded As Boolean
If Not Seeded Then
Seeded = True
Randomize
End If
Dim numbers() As Integer
ReDim numbers(numDigits - 1)
Dim startValue As Integer
startValue = sum \ numDigits ' Integer Division
Dim i As Integer
For i = 1 To numDigits
numbers(i - 1) = startValue
Next
If numDigits * startValue <> sum Then
numbers(numDigits - 1) = sum - ((numDigits - 1) * startValue)
End If
Dim index As Integer
Dim j As Integer
For j = 1 To 100
For i = 1 To numDigits
Do
index = Int((numDigits - 1 + 1) * Rnd + 1)
Loop While index = i
If Rnd >= 0.5 Then
If numbers(i - 1) > 1 Then
numbers(i - 1) = numbers(i - 1) - 1
numbers(index - 1) = numbers(index - 1) + 1
End If
Else
If numbers(index - 1) > 1 Then
numbers(index - 1) = numbers(index - 1) - 1
numbers(i - 1) = numbers(i - 1) + 1
End If
End If
Next
Next j
RandomSumSet = numbers
End Function
Sub rnandomnos()
While [A7] <> 40
Calculate
Wend
End Sub
To get a new set of numbers press F9 and then press the button
code below is in the attached file.
Patrick
randNos.xls
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.