Didn't take the time to look over the whole thing, so I don't know about
functionality. But just glancing over it, a couple of things come to mind:
1) strongly type your variables, i.e., if cumDistrArray holds on strings,
then declare it as a string array: "Dim cumDistrArray as Striing()." Not
typing your variables means that each one is initialized as a Variant type.
Variants are assigned a large amount of memory (don't remember exactly how
many bytes) and when the variable is used for the first time, VBA has to
determine what kind of 'type' it is.
2) All the ReDims are very process intensive. (VBA has to assign a new
block of memory and free up the previous.). Any way you could reduce the
number of them, that would help. Have you considered using collections
instead of arrays? They don't have to be dimensioned. (Excel/VBA pros, feel
free to chime in here, as I don't know what the performance trade-offs would
be, using collections instead of arrays.)
Hope this is helpful.
-EW
"maca" wrote:
Hi ,
Here the first function (for 300 input cells, it takes almost 30
seconds).
Function NewOmega(retArray, Threshold)
Application.Volatile
Dim n As Integer
Dim distrArray
Dim limitArray
Dim helpArray
Dim cumDistrArray
Dim cumCumArray
Dim cum1DistrArray
Dim cum1CumArray
Dim targetArray
Dim helpOmega
Dim om As Double
n = Application.Count(retArray)
If (Threshold < Application.Max(retArray)) And (Threshold
Application.Min(retArray)) Then
ReDim limitArray(n)
limitArray(1) = Application.Min(retArray)
limitArray(n) = Application.Max(retArray)
For i = 2 To n - 1
limitArray(i) = limitArray(i - 1) + (Application.Max(retArray)
- Application.Min(retArray)) / n
Next i
ReDim helpArray(1 To n)
helpArray(1) = 1
For i = 2 To n
For j = 1 To n
If (retArray(j) = limitArray(i - 1)) And (retArray(j) <
limitArray(i)) Then
helpArray(i) = helpArray(i) + 1
End If
Next j
Next i
ReDim distrArray(1 To n)
For i = 1 To (n)
distrArray(i) = helpArray(i) / n
Next i
ReDim cumDistrArray(1 To n)
cumDistrArray(1) = distrArray(1)
For i = 2 To (n)
cumDistrArray(i) = cumDistrArray(i - 1) + distrArray(i)
Next i
ReDim cumCumArray(1 To n)
cumCumArray(1) = cumDistrArray(1)
For i = 2 To (n)
cumCumArray(i) = cumCumArray(i - 1) + cumDistrArray(i)
Next i
ReDim cum1DistrArray(1 To n)
cum1DistrArray(1) = 1
For i = 2 To (n)
cum1DistrArray(i) = 1 - cumDistrArray(i - 1)
Next i
ReDim cum1CumArray(1 To n)
cum1CumArray(1) = 1
For i = 2 To (n)
cum1CumArray(i) = cum1CumArray(i - 1) + cum1DistrArray(i)
Next i
ReDim helpOmega(1 To n)
helpOmega(1) = 999999
For i = 2 To (n)
helpOmega(i) = (Application.Max(cum1CumArray) -
cum1CumArray(i)) / cumCumArray(i)
Next i
For i = 1 To n - 1
If (Threshold = limitArray(i)) And Threshold < limitArray(i +
1) Then
NewOmega = helpOmega(i + 1)
End If
Next i
Else
If Threshold = Application.Min(retArray) Then
NewOmega = "There is no loss"
Else
If Threshold = Application.Max(retArray) Then
NewOmega = "There is no gain"
Else
NewOmega = ""
End If
End If
End If
End Function
and the second function, using the first one:
Function OmegaOfThreshold(retArray)
Application.Volatile
Dim n As Integer
Dim ThresholdArray
Dim OmegaOfL
n = Application.Count(retArray)
ReDim ThresholdArray(1 To n)
ThresholdArray(1) = Application.Min(retArray)
ThresholdArray(n) = Application.Max(retArray)
For i = 2 To n - 1
ThresholdArray(i) = ThresholdArray(i - 1) +
(Application.Max(retArray) - Application.Min(retArray)) / n
Next i
ReDim OmegaOfL(1 To n)
For i = 1 To n
If (NewOmega(retArray, ThresholdArray(i)) = "There is no loss")
Or (NewOmega(retArray, ThresholdArray(i)) = "There is no gain") Or
(NewOmega(retArray, ThresholdArray(i)) <= 0) Then
OmegaOfL(i) = ""
Else
OmegaOfL(i) = Application.Ln(NewOmega(retArray,
ThresholdArray(i)))
End If
Next i
OmegaOfThreshold = Application.Transpose(Array(OmegaOfL))
End Function
The second one makes Excel stop.
Tks,
Maca.
--
maca
------------------------------------------------------------------------
maca's Profile: http://www.excelforum.com/member.php...o&userid=24892
View this thread: http://www.excelforum.com/showthread...hreadid=387489