Speedy code required
 

One improvement would be to put the oringal TRNG values in a SAVED area in
the worksheet. Then to copy these values from SAVED area on the worksheet to
to the TRNG Range. This would be faster than to copy the Tvals() array back
into the worksheet. When repeating code over so many times any little
improvement will help.

"David" wrote:

My code is given below
It runs a simulation of a situation similar to a raffle draw
Each player is allocated "tickets" - ticket holdings are stored in Trng (n x
1)
Once a player "wins a prize" his remaining tickets are removed from the draw
Draw outcome is determined by comparing Rnd with remaining tickets
For each "Do" loop ranks 1 to n is allocated and stored in an n x n range
"profiles"
In this way the probabilities of outcomes for each player is arrived at
The problem is that the code is too slow for a large number of players
For example 6 hours for 100 players X 100K loops on my pc
Any ideas for speeding it up would be appreciated

Dim Trng As Range, profiles As Range
Dim r As Integer, n As Integer, place As Integer
Dim Tvals(), x As Double
Application.ScreenUpdating = False
Set Trng = Range("Trng")
n = Trng.Cells.Count
Set profiles = Trng.Offset(, 3).Resize(n, n)

ReDim Tvals(1 To n)
'\\ Save Trng values in array
For r = 1 To n
Tvals(r) = Trng.Cells(r)
Next r
profiles.ClearContents

Do
For place = 1 To n
'\\ determine Place(i)
x = Rnd * WorksheetFunction.Sum(Trng)
For Each cl In Trng
If cl < "" Then
tSum = Application.Sum(Range(Trng.Cells(1), cl))
If x < tSum Then
With Intersect(cl.EntireRow, profiles.Columns(place))
.Value = .Value + 1
End With
cl.ClearContents
Exit For
End If
End If
Next cl
Next place
'\\ re-populate Trng with original values
For r = 1 To n
Trng.Cells(r) = Tvals(r)
Next r
'\\ 100 loops for example
Loop Until Application.Sum(profiles.Columns(1)) 100

Speedy code required
 

Thanks Joel
Your suggestion saves 5% + on run time

"Joel" wrote:

One improvement would be to put the oringal TRNG values in a SAVED area in
the worksheet. Then to copy these values from SAVED area on the worksheet to
to the TRNG Range. This would be faster than to copy the Tvals() array back
into the worksheet. When repeating code over so many times any little
improvement will help.

"David" wrote:

My code is given below
It runs a simulation of a situation similar to a raffle draw
Each player is allocated "tickets" - ticket holdings are stored in Trng (n x
1)
Once a player "wins a prize" his remaining tickets are removed from the draw
Draw outcome is determined by comparing Rnd with remaining tickets
For each "Do" loop ranks 1 to n is allocated and stored in an n x n range
"profiles"
In this way the probabilities of outcomes for each player is arrived at
The problem is that the code is too slow for a large number of players
For example 6 hours for 100 players X 100K loops on my pc
Any ideas for speeding it up would be appreciated

Dim Trng As Range, profiles As Range
Dim r As Integer, n As Integer, place As Integer
Dim Tvals(), x As Double
Application.ScreenUpdating = False
Set Trng = Range("Trng")
n = Trng.Cells.Count
Set profiles = Trng.Offset(, 3).Resize(n, n)

ReDim Tvals(1 To n)
'\\ Save Trng values in array
For r = 1 To n
Tvals(r) = Trng.Cells(r)
Next r
profiles.ClearContents

Do
For place = 1 To n
'\\ determine Place(i)
x = Rnd * WorksheetFunction.Sum(Trng)
For Each cl In Trng
If cl < "" Then
tSum = Application.Sum(Range(Trng.Cells(1), cl))
If x < tSum Then
With Intersect(cl.EntireRow, profiles.Columns(place))
.Value = .Value + 1
End With
cl.ClearContents
Exit For
End If
End If
Next cl
Next place
'\\ re-populate Trng with original values
For r = 1 To n
Trng.Cells(r) = Tvals(r)
Next r
'\\ 100 loops for example
Loop Until Application.Sum(profiles.Columns(1)) 100