There are a few things that might help.
1. Change your integers to longs. Longs are actualy more efficient than
integers. Since Ints are 16bit but your system is 32 bit there is extra
overhead to using integers. Not much but a bit... The only time you want to
use an iteger is if you have an API or such requiring an integer...

2. Disable calculation. Each time you write data back to the sheet you might
be requiring the sheet to be recalculate.
Application.Calculation = xlcalculationmanual
'your code
Application.Calculation = xlcalculationautomatic

3. There are more elegant ways to deal with the arrays. Take a look at this
code to see how to get ranges into arrays and then back out to the sheet...

Sub test()
Dim rng As Range
Dim ary As Variant
Dim lng As Long

Set rng = Range("A1:A10")
ary = rng.Value

For lng = 1 To 10
'MsgBox ary(lng, 1)
Next lng

With Application
Range("B1:B10").Value = ary
End With
End Sub

Note that if you had a single dimension array you could still coerce it to 2
dimensions using application.Transpose(ary) at which point you can write it
to a range...
--
HTH...

Jim Thomlinson


"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

Thanks Jim,
Can't wait to try your suggestions - just the sort of thing I was hoping for
I'll post back with results

"Jim Thomlinson" wrote:

There are a few things that might help.
1. Change your integers to longs. Longs are actualy more efficient than
integers. Since Ints are 16bit but your system is 32 bit there is extra
overhead to using integers. Not much but a bit... The only time you want to
use an iteger is if you have an API or such requiring an integer...

2. Disable calculation. Each time you write data back to the sheet you might
be requiring the sheet to be recalculate.
Application.Calculation = xlcalculationmanual
'your code
Application.Calculation = xlcalculationautomatic

3. There are more elegant ways to deal with the arrays. Take a look at this
code to see how to get ranges into arrays and then back out to the sheet...

Sub test()
Dim rng As Range
Dim ary As Variant
Dim lng As Long

Set rng = Range("A1:A10")
ary = rng.Value

For lng = 1 To 10
'MsgBox ary(lng, 1)
Next lng

With Application
Range("B1:B10").Value = ary
End With
End Sub

Note that if you had a single dimension array you could still coerce it to 2
dimensions using application.Transpose(ary) at which point you can write it
to a range...
--
HTH...

Jim Thomlinson


"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

Jim,
Thanks
xlcalculationmanual saves 10% to 15 % on run time, a significant gain.
No noticable improvement with the other suggestions
Do you think that taking everytning "off sheet" using arrays would be better?


"Jim Thomlinson" wrote:

There are a few things that might help.
1. Change your integers to longs. Longs are actualy more efficient than
integers. Since Ints are 16bit but your system is 32 bit there is extra
overhead to using integers. Not much but a bit... The only time you want to
use an iteger is if you have an API or such requiring an integer...

2. Disable calculation. Each time you write data back to the sheet you might
be requiring the sheet to be recalculate.
Application.Calculation = xlcalculationmanual
'your code
Application.Calculation = xlcalculationautomatic

3. There are more elegant ways to deal with the arrays. Take a look at this
code to see how to get ranges into arrays and then back out to the sheet...

Sub test()
Dim rng As Range
Dim ary As Variant
Dim lng As Long

Set rng = Range("A1:A10")
ary = rng.Value

For lng = 1 To 10
'MsgBox ary(lng, 1)
Next lng

With Application
Range("B1:B10").Value = ary
End With
End Sub

Note that if you had a single dimension array you could still coerce it to 2
dimensions using application.Transpose(ary) at which point you can write it
to a range...
--
HTH...

Jim Thomlinson


"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