Results 1 to 8 of 8

20040716, 13:28 #1
 Join Date
 Sep 2003
 Location
 Louisville, Kentucky, USA
 Posts
 134
 Thanks
 0
 Thanked 0 Times in 0 Posts
VBA Design Help (Ranking Arrays) (xl97, Win2000)
I have an unsorted column of numbers and each number has an associated probability. I need to sort the numbers and then average the n lowest values. n is determined by starting at the lowest number and then proceeding up the list until the sum of the associated probabilities reaches some desired threshhold (i.e. 25%). I've got a function that works and I'm just wanting to see if anyone can help make this more efficient since this function does quite a few loops and it is expected to be used many times in a workbook:
<pre>Option Explicit
Option Base 1
Function CTE(Level, Values As Object, Optional Max0 = False, _
Optional Probabilities As Object, Optional Smallest = 1)
' Computes Conditional Tail Expectation from the specified
' percentage (i.e. 1Level) of Values
'
' If the specified number of Values is noninteger, it will linearly interpolate
' between the CTEs given by the two integer number of Values
'
' If Max0=TRUE, any Values greater than 0 will be set to 0
' If Smallest=1, it will compute the average of the smallest Values
' If Smallest<>1, it will compute the average of the largest Values
'
' Created by DC 9/23/2003
' *7/15/2004 Modified to handle duplicate values. Prior version did not do this properly.
' Also modified to require explicit declaration of variable types. Also modified to
' normalize Probabilities so they sum to 1.00
'
If Level > 1 Or Level < 0 Then
CTE = CVErr(xlValue)
Exit Function
End If
Dim SortedValues(), SortedProbs(), SumProbs As Double
Dim PriorProb, NewProb, PriorTotal, NewTotal, CTE1, CTE2 As Double
Dim i, j, k, N, R As Long
N = Values.Count
ReDim SortedValues(1 To N), SortedProbs(1 To N)
SumProbs = 0
For i = 1 To N
R = Application.Rank(Values(i), Values)
Do While Not (IsEmpty(SortedValues®))
R = R + 1
Loop
If Max0 Then
SortedValues® = Application.Min(0, Values(i))
Else
SortedValues® = Values(i)
End If
If IsArray(Probabilities) Then
SortedProbs® = Probabilities(i)
Else
SortedProbs® = 1 / N
End If
SumProbs = SumProbs + SortedProbs®
Next i
For i = 1 To N
If IsEmpty(SortedProbs(i)) Then
CTE = CVErr(xlValue)
Exit Function
End If
SortedProbs(i) = SortedProbs(i) / SumProbs
Next i
If Smallest = 1 Then
j = N + 1: k = 1
Else
j = 0: k = 1
End If
NewTotal = 0: NewProb = 0: CTE1 = 0: CTE2 = 0
Do While NewProb < (1  Level)
PriorTotal = NewTotal
PriorProb = NewProb
j = j + k
NewTotal = NewTotal + SortedProbs(j) * SortedValues(j)
NewProb = NewProb + SortedProbs(j)
Loop
CTE1 = PriorTotal / PriorProb
CTE2 = NewTotal / NewProb
CTE = CTE1 + (CTE2  CTE1) * ((1  Level)  PriorProb) / (NewProb  PriorProb)
End Function
</pre>

20040716, 14:08 #2
 Join Date
 Jan 2001
 Location
 South Carolina, USA
 Posts
 7,295
 Thanks
 0
 Thanked 0 Times in 0 Posts
Re: VBA Design Help (Ranking Arrays) (xl97, Win2000)
Since I don't find a property or method of the Application object named Rank, I am not sure what the routine is doing. So I have not analyzed it completely. However, I will make one comment that should make it more efficient. VBA works more efficiently if variables are DIMed to the proper type. You have several statements like the following:
<pre> Dim i, j, k, N, R As Long
</pre>
If you are expecting that to DIM i,j,k,N,R as Long, that is not what is happening. That statement will DIM i, j, k, and N as Variants, and R as a Long. To do what I think you want, you would need to change that to:
<pre> Dim i As Long, j As Long, k As Long, N As Long, R As Long
</pre>
You must specify t he type of each variable in t he list.Legare Coleman

20040716, 16:07 #3
 Join Date
 Sep 2003
 Location
 Louisville, Kentucky, USA
 Posts
 134
 Thanks
 0
 Thanked 0 Times in 0 Posts
Re: VBA Design Help (Ranking Arrays) (xl97, Win2000)
Legare,
Thanks for the guidance on the Dim statement. I'm sure I've repeated this mistake many times so thanks for setting me straight.
The Application.Rank statement calls the Rank worksheet function which gives me the ranking of each Values(i) within the Values array. This is how I'm sorting my array.
Upon reviewing the Excel97 help, it says, "In previous versions of Microsoft Excel, worksheet functions were contained by the Application object." I guess the proper syntax is now application.worksheetfunction.rank

20040716, 16:35 #4
 Join Date
 Feb 2001
 Location
 Weert, Limburg, Netherlands
 Posts
 4,812
 Thanks
 0
 Thanked 0 Times in 0 Posts
Re: VBA Design Help (Ranking Arrays) (xl97, Win2000)
IN Excel 5, the worksheetfunction object did not exist (to call worksheet functions one just used Application.FunctionName) and for backward compatibility it is still allowed to omit that.
Jan Karel Pieterse
Microsoft Excel MVP, WMVP
www.jkpads.com
Professional Office Developers Association

20040716, 19:13 #5
 Join Date
 Jan 2001
 Location
 South Carolina, USA
 Posts
 7,295
 Thanks
 0
 Thanked 0 Times in 0 Posts
Re: VBA Design Help (Ranking Arrays) (xl97, Win2000)
I kind of thought that was what you were doing. I'll have to spend some more time looking at it, but I would think that this would be a pretty slow way to sort.
Legare Coleman

20040720, 13:52 #6
 Join Date
 Sep 2003
 Location
 Louisville, Kentucky, USA
 Posts
 134
 Thanks
 0
 Thanked 0 Times in 0 Posts
Re: VBA Design Help (Ranking Arrays) (xl97, Win2000)
Legare,
Your comments made me think back to my university days and programming "bubble sort" routines in FORTRAN. Back then, it was considered an efficient way to sort so I tried implementing it in VBA and my testing indicates that it is indeed faster. The code is a little less readable than using the RANK function, but it seems to run considerably faster in most cases. I was also having trouble with the RANK function returning a zero value in some cases (perhaps due to inadequate numeric precision) so this solution avoids that.
<pre>Function CTE(Level As Double, Values As Object, Optional Max0 As Boolean = False, _
Optional Probabilities As Variant, Optional Smallest As Boolean = True)
' Computes Conditional Tail Expectation from the specified percentage (i.e. 1Level) of Values
'
' If Max0=TRUE, any Values greater than 0 will be set to 0
' If Smallest=TRUE, it will compute the average of the smallest Values
' If Smallest<>TRUE, it will compute the average of the largest Values
'
' DC 9/23/2003
' *7/15/2004 Modified to handle duplicate values. Prior version did not do this properly.
' Also modified to require explicit declaration of variable types. Also modified to
' normalize Probabilities so they sum to 1.00
' *7/20/2004 Modified to improve efficiency
'
CTE = CVErr(xlErrValue)
If Level >= 1 Or Level < 0 Then Exit Function
Dim SortedValues() As Double, SortedProbs() As Double, SumProbs As Double, Temp As Double
Dim TotalProb As Double, TotalValue As Double, ProbLimit As Double
Dim i As Long, j As Long, N As Long
Dim SortFinished As Boolean, UniqueProbs As Boolean
Dim wfunc As Object
Set wfunc = Application.WorksheetFunction
N = Values.Count
ReDim SortedValues(1 To N), SortedProbs(1 To N)
UniqueProbs = IsArray(Probabilities)
SumProbs = 0
For i = 1 To N
If Max0 Then
SortedValues(i) = wfunc.Min(0, Values(i))
Else
SortedValues(i) = Values(i)
End If
If UniqueProbs Then
SortedProbs(i) = Probabilities(i)
Else
SortedProbs(i) = 1 / N
End If
SumProbs = SumProbs + SortedProbs(i)
Next i
SortFinished = False
Do While Not (SortFinished)
SortFinished = True
For i = 1 To N  1
If SortedValues(i) < SortedValues(i + 1) Then
SortFinished = False
Temp = SortedValues(i)
SortedValues(i) = SortedValues(i + 1)
SortedValues(i + 1) = Temp
If UniqueProbs Then
Temp = SortedProbs(i)
SortedProbs(i) = SortedProbs(i + 1)
SortedProbs(i + 1) = Temp
End If
End If
Next i
Loop
If Smallest Then
i = N + 1: j = 1
Else
i = 0: j = 1
End If
TotalValue = 0: TotalProb = 0: ProbLimit = 1  Level
Do While TotalProb < ProbLimit
i = i + j
TotalValue = TotalValue + SortedProbs(i) / SumProbs * SortedValues(i)
TotalProb = TotalProb + SortedProbs(i) / SumProbs
Loop
CTE = (TotalValue  (TotalProb  ProbLimit) * SortedValues(i)) / ProbLimit
End Function
</pre>

20040720, 14:10 #7
 Join Date
 Jan 2001
 Location
 South Carolina, USA
 Posts
 7,295
 Thanks
 0
 Thanked 0 Times in 0 Posts
Re: VBA Design Help (Ranking Arrays) (xl97, Win2000)
Sorry, I meant to get back to this message and I forgot about it. What you did was similar to what I was going to do but with a different sort algorithm. Try the sort algorithm in the code below, it may be a little faster than what you did. I don't have your data so I could not test it.
<pre>Function CTE(Level As Double, Values As Object, Optional Max0 As Boolean = False, _
Optional Probabilities As Variant, Optional Smallest As Boolean = True)
' Computes Conditional Tail Expectation from the specified percentage (i.e. 1Level) of Values
'
' If Max0=TRUE, any Values greater than 0 will be set to 0
' If Smallest=TRUE, it will compute the average of the smallest Values
' If Smallest<>TRUE, it will compute the average of the largest Values
'
' DC 9/23/2003
' *7/15/2004 Modified to handle duplicate values. Prior version did not do this properly.
' Also modified to require explicit declaration of variable types. Also modified to
' normalize Probabilities so they sum to 1.00
' *7/20/2004 Modified to improve efficiency
'
CTE = CVErr(xlErrValue)
If Level >= 1 Or Level < 0 Then Exit Function
Dim SortedValues() As Double, SortedProbs() As Double, SumProbs As Double, Temp As Double
Dim TotalProb As Double, TotalValue As Double, ProbLimit As Double
Dim i As Long, j As Long, N As Long
Dim SortFinished As Boolean, UniqueProbs As Boolean
Dim wfunc As Object
Set wfunc = Application.WorksheetFunction
N = Values.Count
ReDim SortedValues(1 To N), SortedProbs(1 To N)
UniqueProbs = IsArray(Probabilities)
SumProbs = 0
For i = 1 To N
If Max0 Then
SortedValues(i) = wfunc.Min(0, Values(i))
Else
SortedValues(i) = Values(i)
End If
If UniqueProbs Then
SortedProbs(i) = Probabilities(i)
Else
SortedProbs(i) = 1 / N
End If
SumProbs = SumProbs + SortedProbs(i)
Next i
For i = 1 To N  1
For j = i + 1 To N
If SortedValues(i) > SortedValues(j) Then
Temp = SortedValues(i)
SortedValues(i) = SortedValues(j)
SortedValues(j) = Temp
If UniqueProbs Then
Temp = SortedProbs(i)
SortedProbs(i) = SortedProbs(j)
SortedProbs(j) = Temp
End If
End If
Next j
Next i
If Smallest Then
i = N + 1: j = 1
Else
i = 0: j = 1
End If
TotalValue = 0: TotalProb = 0: ProbLimit = 1  Level
Do While TotalProb < ProbLimit
i = i + j
TotalValue = TotalValue + SortedProbs(i) / SumProbs * SortedValues(i)
TotalProb = TotalProb + SortedProbs(i) / SumProbs
Loop
CTE = (TotalValue  (TotalProb  ProbLimit) * SortedValues(i)) / ProbLimit
End Function
</pre>
Legare Coleman

20040720, 16:29 #8
 Join Date
 Sep 2003
 Location
 Louisville, Kentucky, USA
 Posts
 134
 Thanks
 0
 Thanked 0 Times in 0 Posts
Re: VBA Design Help (Ranking Arrays) (xl97, Win2000)
Legare,
Thanks for your thoughts on this. It looks like your algorithm will always pass through the data exactly .5*N^2 times ((N1)+(N2)+...+1). If I recall from my old comp sci classes, I think I will average N/2 passes through the data to sort my list. Since each pass is N1 loops, I think I will have an average of .5*(N^2N), but I could be wrong.