+ Reply to Thread
Results 1 to 4 of 4

Speed-up a macro!

  1. #1
    Registered User
    Join Date
    07-04-2005
    Posts
    9

    Speed-up a macro!

    Hi
    I have 2 macros/functions that take a lot of time to finish the calculations. Is there any possibility to speed up a macro?
    If I try to apply one of the functions, it does not even finish to select the column of 300 data. Excel just stops selecting by the first 100 data and then it does not react to any command.
    Rgds,
    Maca.
    :confused:

  2. #2
    Forum Contributor
    Join Date
    03-24-2004
    Location
    Edam Netherlands
    Posts
    181
    post your macro's

    then I will look at them

  3. #3
    Registered User
    Join Date
    07-04-2005
    Posts
    9
    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.

  4. #4
    Eric White
    Guest

    Re: Speed-up a macro!

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


+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1