slow code?
Author Message slow code?

Hello,

Can anyone tell me why this code is so slow?  The BubbleSort function does
not seem to be the problem...   Mabey the:

If Application.WorksheetFunction.IsText(e) = True Then GoTo Bottom

Any ideas would be great...
Ernst.

Sub Sunday()

Dim TheArray(60, 3) As Variant
Dim a, C, e, R
Dim Lunch, After, Dinner, Late As Boolean

a = 0

Range("A9:C49").ClearContents

' Create the array.

For Each C In Range("Sunday")

a = a + 1

TheArray(a, 1) = C.Value
TheArray(a, 2) = C.Cells(1, 2).Value
TheArray(a, 3) = C.Cells(1, -1).Value

Next

' Sort the Array and display the values in order.

BubbleSort TheArray

R = 9

For a = 1 To UBound(TheArray)

e = TheArray(a, 1)

If e = "" Then GoTo Bottom
If Application.WorksheetFunction.IsText(e) = True Then GoTo Bottom

If Lunch = False Then
If e >= 0.458 Then
R = R + 1
Lunch = True
End If
End If

If After = False Then
If e >= 0.625 Then
R = R + 7
After = True
End If
End If

If Dinner = False Then
If e >= 0.708 Then
R = R + 1
Dinner = True
End If
End If

If Late = False Then
If e >= 0.833 Then
R = R + 1
Late = True
End If
End If

Range("A" & R).Value = TheArray(a, 1)
Range("B" & R).Value = TheArray(a, 2)
Range("C" & R).Value = TheArray(a, 3)

R = R + 1

Bottom:

Next

End Sub

Thu, 08 Jul 2004 08:21:21 GMT  slow code?
Have you tried setting the Calculation property to
xlCalculationManual at the beginning of your code
and setting it back to xlCalculationAutomatic at the
end? Also turn screen updating off. I wouldn't think
it would take all that long to run through a 60 x 3
( or a 61 x 4) array. I was not able to understand the
logic behind your code but the following untested code
appears to me to do what your code does. You could
test it to see if it works and if you gain any speed. If
you test it and have a problem with it let me know.

If anyone else wishes to comment on the following code

Sub Sunday()
Dim TheArray() As Variant
Dim EndArray(1 To 41, 1 To 3) As Variant
Dim Compare(1 To 4) As Double
Dim C As Range
Dim a As Integer, s As Integer, R As Integer
Dim b As Integer, x As Integer
Dim e As Variant

Compare(1) = 0.458 '''Lunch
Compare(2) = 0.625 '''After
Compare(3) = 0.708 '''Diner
Compare(4) = 0.833 '''Late

s = Application.Count(Range("Sunday"))
ReDim TheArray(1 To s, 1 To 3)
a = 0

Application.ScreenUpdating = False
Range("A9:C49").ClearContents

For Each C In Range("Sunday")
If TypeName(C.Value) = "Double" Then
a = a + 1
TheArray(a, 1) = C.Value
TheArray(a, 2) = C.Cells(1, 2).Value
TheArray(a, 3) = C.Cells(1, -1).Value
End If
Next

BubbleSort TheArray

R = 1
a = 1
b = 1

Do While a <= s
e = TheArray(a, 1)
For x = b To 4
If e >= Compare(x) Then
If x = 2 Then
'''After
R = R + 7
Else
'''Lunch, Dinner or Late
R = R + 1
End If
b = b + 1
Else
Exit For
End If
Next
EndArray(R, 1) = TheArray(a, 1)
EndArray(R, 2) = TheArray(a, 2)
EndArray(R, 3) = TheArray(a, 3)
R = R + 1
a = a + 1
Loop
Range("A9:C49").Value = EndArray()
Application.ScreenUpdating = True

End Sub

HTH,
Phil.

========================
<< Hello,

Can anyone tell me why this code is so slow?  The BubbleSort function does
not seem to be the problem...   Mabey the:

If Application.WorksheetFunction.IsText(e) = True Then GoTo Bottom

Any ideas would be great...
Ernst.

Sub Sunday()

Dim TheArray(60, 3) As Variant
Dim a, C, e, R
Dim Lunch, After, Dinner, Late As Boolean

a = 0

Range("A9:C49").ClearContents

' Create the array.

For Each C In Range("Sunday")

a = a + 1

TheArray(a, 1) = C.Value
TheArray(a, 2) = C.Cells(1, 2).Value
TheArray(a, 3) = C.Cells(1, -1).Value

Next

' Sort the Array and display the values in order.

BubbleSort TheArray

R = 9

For a = 1 To UBound(TheArray)

e = TheArray(a, 1)

If e = "" Then GoTo Bottom
If Application.WorksheetFunction.IsText(e) = True Then GoTo Bottom

If Lunch = False Then
If e >= 0.458 Then
R = R + 1
Lunch = True
End If
End If

If After = False Then
If e >= 0.625 Then
R = R + 7
After = True
End If
End If

If Dinner = False Then
If e >= 0.708 Then
R = R + 1
Dinner = True
End If
End If

If Late = False Then
If e >= 0.833 Then
R = R + 1
Late = True
End If
End If

Range("A" & R).Value = TheArray(a, 1)
Range("B" & R).Value = TheArray(a, 2)
Range("C" & R).Value = TheArray(a, 3)

R = R + 1

Bottom:

Next

End Sub >>

Fri, 09 Jul 2004 11:10:18 GMT

 Page 1 of 1 [ 2 post ]

Relevant Pages