D
David
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
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