RePost - Code Optimization...

[Lavey]

Hi all,

Really need to pick somebody's brain....

I have written a function to calcualte true working days in fractions of an hour, the trouble is when I run a query that uses my function on the base data from my table (@5,000 records) it takes about 15 mins to calculate each time!!

I have re-written twice now, (changed if's to select's etc.)

Is there anybody out there that could help me to optimize this piece of code - or is this just something that is gonna take a lot of time due to the processing?
(I am running on a P3 700 with 128 Ram).

Code as follows:

Public Function NonWorkingDays(DateIn, DateOut)
On Error GoTo CalcError:

Dim TotalHours As Integer
Dim HoursToDrop As Integer
Dim StartDate As Date
Dim EndDate As Date

'set up start/end dates/totalhours and reset hours to drop to 0
StartDate = Format(DateIn, "general date&quot
EndDate = Format(DateOut, "general date&quot
TotalHours = DateDiff("n", StartDate, EndDate)
HoursToDrop = 0

Dim Weekstart As Integer
Dim WeekEnd As Integer

Weekstart = WeekDay(StartDate)
WeekEnd = WeekDay(EndDate)

Dim Monday As Date
Dim Newstring As String

'if received and completed on sat or sun then calc hours only or set first working day to monday morning
Select Case Weekstart
Case 1
If WeekEnd = 1 And TotalHours < 1440 Then
NonWorkingDays = Format(TotalHours / 60, &quot;0.0&quot
Exit Function
Else
Newstring = StartDate + 1
Newstring = Left(Newstring, 10) & &quot; 08:00&quot;
Monday = Newstring
HoursToDrop = DateDiff(&quot;n&quot;, StartDate, Monday)
End If
Case 7
If WeekEnd = 7 Or WeekEnd = 1 And TotalHours < 2880 Then
NonWorkingDays = Format(TotalHours / 60, &quot;0.0&quot
Exit Function
Else
Newstring = StartDate + 2
Newstring = Left(Newstring, 10) & &quot; 08:00&quot;
Monday = Newstring
HoursToDrop = DateDiff(&quot;n&quot;, StartDate, Monday)
End If
End Select

Dim DateCounter As Date
Dim HoliDays As Long
Dim Holicount As Integer

'add up all sat/sun and holidays between startdate and end date
Select Case Newstring
Case &quot;&quot;
DateCounter = StartDate
Do
If WeekDay(DateCounter) = 7 Or WeekDay(DateCounter) = 1 Then
HoursToDrop = HoursToDrop + 1440
Else
HoliDays = DCount(&quot;holidate&quot;, &quot;HolidayTable&quot;, &quot;holidate = #&quot; & DateCounter & &quot;#&quot
Holicount = Holicount + HoliDays
End If
DateCounter = DateCounter + 1
Loop While DateCounter < EndDate
Case Else
DateCounter = Newstring
Do
If WeekDay(DateCounter) = 7 Or WeekDay(DateCounter) = 1 Then
HoursToDrop = HoursToDrop + 1440
Else
HoliDays = DCount(&quot;holidate&quot;, &quot;HolidayTable&quot;, &quot;holidate = #&quot; & DateCounter & &quot;#&quot
If Holicount > 0 Then Holicount = Holicount + HoliDays
End If
DateCounter = DateCounter + 1
Loop While DateCounter < EndDate
End Select

'true working hours is total hours minus the hours to be dropped - and there you go !

'Holicount = Holicount * 1440
'HoursToDrop = HoursToDrop + (Holicount * 1440)
NonWorkingDays = TotalHours - HoursToDrop + (Holicount * 1440)
NonWorkingDays = Format(NonWorkingDays / 60, &quot;0.0&quot

Exit Function

CalcError:
If Err.number = 94 Or Err.number = 13 Then
NonWorkingDays = Null
Else
DisplayMessage &quot;TR calc error - &quot; & Err.number & &quot; &quot; & Err.Description
End If
End Function


Any ideas ?
Thanks alot!!

 

[JDettman]

What's hurting you is the DCount() for the holidays. Your testing each and every date to see if it's a holiday.

It would be much more efficent to get ALL the holidays between start/end dates with one recordset, loop through them and total, rather then checking each date to see if it's a holiday.

I also think you need to step back and look at the overall process and what the goal is. For example, your function doesn't really care if it's a weekend or a holiday in the end result (both mean hours off). Given that, you can take a totaly different approach. Below is some code that might give you a few ideas.

Questions?
Jim.


Function ElapsedBDays(ByVal StartDate As Variant, ByVal EndDate As Variant) As Variant
' Pass parameters ByVal since we modify them, possibly, during the execution of this code.

' This function just counts up the number of weekdays, and then subtracts off the number of
' holidays (from the Holidays table) that fall within the passed in timeframe.

' Note that the Holidays table must be manually maintained for each year (and you'd probably
' want more than one year's worth of dates in there), since many holidays move from year to
' year. If anyone out there cares to modify this so there are TWO tables, one for fixed
' holidays and one for variable, I'd love to see it. Go for it!

' -- Ken Getz (76137, 3650)

Dim Days As Integer
Dim WeekDays As Integer
Dim Holidays As Integer
Dim temp As Variant

' Make sure both parameters can be regarded as dates.
' If not, return NULL.
If Not IsDate(StartDate) Or Not IsDate(EndDate) Then
ElapsedBDays = Null
Exit Function
End If

' If the dates were passed in in string format, convert them to dates now.
If VarType(StartDate) = V_STRING Then StartDate = DateValue(StartDate)
If VarType(EndDate) = V_STRING Then EndDate = DateValue(EndDate)
If EndDate < StartDate Then
' Swap them!
temp = EndDate
EndDate = StartDate
StartDate = temp
End If

' Get the starting day count (figuring that if the two days passed in
' are the same, we'll return 1).
'
' If you think that entering two dates both of which are the same should return
' a 0, then remove the &quot;+1&quot; below.
Days = DateDiff(&quot;d&quot;, StartDate, EndDate) + 1

' Get starting date to be a week day.
While (DatePart(&quot;w&quot;, StartDate) - 1) Mod 6 = 0
StartDate = DateAdd(&quot;d&quot;, StartDate, 1)
Days = Days - 1
Wend
' Get ending date to be a week day.
While (DatePart(&quot;w&quot;, EndDate) - 1) Mod 6 = 0
EndDate = DateAdd(&quot;d&quot;, EndDate, -1)
Days = Days - 1
Wend

' Subtract off weekend days. We do this by figuring out which ordinal week of the year
' each date is in, and multiplying the difference by two (since there are two
' weekend days for each week). That is, if the difference is 0, the two days
' are in the same week. If the difference is 1, then we have two weekend days.
WeekDays = Days - Abs(DateDiff(&quot;ww&quot;, EndDate, StartDate) * 2)

' Look through the data table for dates that fall in our allotted range.
Holidays = DCount(&quot;Date&quot;, &quot;Holidays&quot;, &quot;(Date Between &quot; & USAFormat(StartDate) & &quot; And &quot; & USAFormat(EndDate) & &quot AND (DatePart('w', [Date])-1) Mod 6 <> 0&quot

' The answer to our quest is all the weekdays, minus any holidays we found in the table.
ElapsedBDays = WeekDays - Holidays
End Function

 

[Lavey]

Jim,

Thanks for you input - was running this code in excel (minus the DCount and it has no problems !!) Will look at the DCount again to retrieve the complete number of holiday days then drop them out of the overall number.

The overall process for this function is two fold - fisrtly its used to work out actual processing times for work processed in our department by airline.
So say carrier AA is recevied Fri 0900, extracted Mon 0900, actual turnaround is 24Hours (rather than 72), secondly its used to calculate the hours the inputer has had the carrier in update, so the worker started at Fri 1000 and completed Mon 0800 working hours is 22Hours.

Am I approaching this the wrong way ? Have read the code you posted and will have a go to modify this into hourly.

Thanks alot for your time!
Chris.

 

[Lavey]

This DCount malarky can really slow things down!!
I've now adjusted the code to do a straight count of 'Holidays' between the start and end dates but it's still super slow (I have a crosstab running of this base query and it frezzes my machine !!)

Code...
(as a seperate block from the code I posted before)

HoliDays = DCount(&quot;holidate&quot;, &quot;holidaytable&quot;, &quot;(holidate Between #&quot; & Format(StartDate, &quot;short date&quot & &quot;# And #&quot; & Format(EndDate, &quot;short date&quot & &quot;#)&quot

Is there an alternative solution to this ?

Thanks alot.

 

[JDettman]

Hum... that should be fairly fast. Contrary to popular belief, DCount() can be faster then other methods and in this case, I think it would be.

You do have the holiday table indexed on the date correct?

Jim.

 

[Lavey]

Yep, inexed (primary Key - no dupes)

 

[MichaelRed]

I concur with the domain aggregate functiona as being one source of the poor execution. Referencing the holidays in a table with a lookup process is another. I did not include a TABLE of holidays - or the process to load such a list. I did include an array (with sample holiday dates) and the suggestion to hve a table and load it into the array, which I believe would speed up this process quite a bit. You should -however- be careful with the implementation of this process. I have simply included the array within the procedure, but a 'real world' or production app should load the array in aa global module and simply reference it, since loading it on each call (record) would REALLY be backwards.

Public Function basWrkHrs(StDate As Date, EndDate As Date) As Double

    'Get the number of work HOURS between the given dates

    Dim blnHoliFnd As Boolean       'Flag for Hloiday found
    Dim Holidate(21) As Date        'Table of Holidays
    Dim Idx As Long                 'Index for start/end dates
    Dim Kdx As Long                 'Index / counter for Number of days
    Dim Jdx As Integer              'Index doe the Hloidate array
    Dim MyDate As Date              'Tempdate
    Dim AccumTime As Double         'Hours Accumulated

    Const MinsPerDay = 1440         'Every Minute of the DAY!!
    Const MinsPerHr = 60#           '60 Minutes per Hour

    'For MAINTENANCE purposes, the array should be in a TABLE
    'There SHOULD be a form to add/edit/delete the table.
    
    'At run time, the TABLE should be wholy loaded into the ARRAY
    'to promote execution effiency.

    'Array(Table) of Holiday Dates
    Holidate(0) = #1/1/2001#        'NewYearsDay
    Holidate(1) = #1/17/2001#       'Martin Luther King Day
    Holidate(2) = #2/2/2001#        'Groundhog Day
    Holidate(3) = #2/12/2001#       'Lincon's Birthday
    Holidate(4) = #2/14/2001#       'Valentine's Day
    Holidate(5) = #2/21/2001#       'President's Day
    Holidate(6) = #2/22/2001#       'Washington's Birthday
    Holidate(7) = #3/8/2001#        'Ash Wednesday
    Holidate(8) = #3/17/2001#       'St. Patrick's Day
    Holidate(8) = #4/1/2001#        'April Fool's Day
    Holidate(9) = #4/20/2001#       'Passover
    Holidate(10) = #4/21/2001#      'Good Friday
    Holidate(11) = #5/5/2001#       'Cinco de Mayo
    Holidate(12) = #5/14/2001#      'Mother's Day
    Holidate(13) = #6/11/2001#      'Pentecost
    Holidate(14) = #6/18/2001#      'Father's Day
    Holidate(15) = #7/4/2001#       'Independence Day
    Holidate(16) = #9/4/2001#       'Labor Day
    Holidate(17) = #10/31/2001#     'Halloween
    Holidate(18) = #11/11/2001#     'Vetran's Day
    Holidate(19) = #11/23/2001#     'Thanksgiving
    Holidate(20) = #12/25/2001#     'Christmas
    Holidate(21) = #12/31/2001#     'New Year's Eve


    'Get the incremental Minutes for the Start & End Dates
    If (Not (Weekday(StDate) = vbSaturday Or Weekday(StDate) = vbSunday)) Then
        AccumTime = DateDiff("n", StDate, Format(StDate + 1, "mm/dd/yy"))
    End If

    If (Not (Weekday(EndDate) = vbSaturday Or Weekday(EndDate) = Sunday)) Then
        AccumTime = AccumTime + DateDiff("n", Format(EndDate, "mm/dd/yy"), EndDate)
    End If

    MyDate = Format(StDate + 1, "Short Date")

    'Loop for each day INSIDE the interval
    For Idx = CLng(StDate + 1) To CLng(EndDate) - 1

        blnHoliFnd = False

        If (Weekday(MyDate) = vbSaturday Or Weekday(MyDate) = vbSunday) Then
            blnHoliFnd = True
            GoTo NoTime
        End If

        For Jdx = 0 To UBound(Holidate)

            If (Holidate(Jdx) = MyDate) Then
                blnHoliFnd = True
                Exit For
'             Else
'                Do Nothing, it is NOT a Workday
            End If

        Next Jdx

NoTime:

        'count WHOLE (Work) days
        If (blnHoliFnd = False) Then
            Kdx = Kdx + 1
        End If
    
        MyDate = DateAdd("d", 1, MyDate)
        

    Next Idx

    'Got the number of days.  Now, add work minutes to acuumtime
    AccumTime = AccumTime + CSng(Kdx) * CSng(MinsPerDay)

    basWrkHrs = AccumTime / MinsPerHr

End Function

MichaelRed
m.red@att.net

There is never time to do it right but there is always time to do it over

 

[Lavey]

That's the one guys !!!

This works pucker now (no slow down at all!).

Created a function that runs on the autoexec macro to populate a global array, and then in my code ref that array.

Here are both my pieces of code (if your interested)..

Global...

Public HoliArray() As Date
Public Function FillHoliArray()
Dim DBS As Database
Dim RS As Recordset
Dim Idx As Integer

Set DBS = CurrentDb
Set RS = DBS.OpenRecordset(&quot;select * from holidaytable&quot
RS.MoveLast
RS.MoveFirst
ReDim HoliArray(RS.RecordCount)
For Idx = 0 To RS.RecordCount - 1
With RS
HoliArray(Idx) = !holidate
.MoveNext
End With
Next Idx

End Function

NonworkingDays function.....


Public Function NonWorkingDays(ByVal DateIn As Date, ByVal DateOut As Date)
On Error GoTo CalcError:

Dim TotalHours As Integer
Dim HoursToDrop As Integer
Dim StartDate As Date
Dim EndDate As Date

'set up start/end dates/totalhours and reset hours to drop to 0
StartDate = Format(DateIn, &quot;general date&quot
EndDate = Format(DateOut, &quot;general date&quot
TotalHours = DateDiff(&quot;n&quot;, StartDate, EndDate)
HoursToDrop = 0

Dim WeekStart As Integer
Dim WeekEnd As Integer

WeekStart = WeekDay(StartDate)
WeekEnd = WeekDay(EndDate)

Dim Monday As Date
Dim NewString As String

'if received and completed on sat or sun then calc hours only or set first working day to monday morning
Select Case WeekStart
Case 1
If WeekEnd = 1 And TotalHours < 1440 Then
NonWorkingDays = Format(TotalHours / 60, &quot;0.0&quot
Exit Function
Else
NewString = StartDate + 1
NewString = Left(NewString, 10) & &quot; 08:00&quot;
Monday = NewString
HoursToDrop = DateDiff(&quot;n&quot;, StartDate, Monday)
End If
Case 7
If WeekEnd = 7 Or WeekEnd = 1 And TotalHours < 2880 Then
NonWorkingDays = Format(TotalHours / 60, &quot;0.0&quot
Exit Function
Else
NewString = StartDate + 2
NewString = Left(NewString, 10) & &quot; 08:00&quot;
Monday = NewString
HoursToDrop = DateDiff(&quot;n&quot;, StartDate, Monday)
End If
End Select


'add up all sat/sun between startdate and end date
Dim DateCounter As Date

Select Case NewString
Case &quot;&quot;
DateCounter = StartDate
Do
If WeekDay(DateCounter) = 7 Or WeekDay(DateCounter) = 1 Then
HoursToDrop = HoursToDrop + 1440
End If
DateCounter = DateCounter + 1
Loop While DateCounter < EndDate
Case Else
DateCounter = NewString
Do
If WeekDay(DateCounter) = 7 Or WeekDay(DateCounter) = 1 Then
HoursToDrop = HoursToDrop + 1440
End If
DateCounter = DateCounter + 1
Loop While DateCounter < EndDate
End Select

Dim J As Date
Dim I As Integer
Dim Holidays As Integer

StartDate = Format(StartDate, &quot;short date&quot
EndDate = Format(EndDate, &quot;short date&quot

For J = StartDate To EndDate
For I = 0 To UBound(HoliArray) - 1
If Not WeekDay(J) = 1 Or WeekDay(J) = 7 Then
If HoliArray(I) = J Then
Holidays = Holidays + 1
End If
End If
Next I
Next J
If Holidays <> 0 Then
Holidays = Holidays * 1440
HoursToDrop = HoursToDrop + Holidays
End If
'true working hours is total hours minus the hours to be dropped - and there you go !

NonWorkingDays = TotalHours - HoursToDrop
NonWorkingDays = Format(NonWorkingDays / 60, &quot;0.0&quot

Exit Function

CalcError:
If Err.number = 94 Or Err.number = 13 Or Err.number = 6 Then
NonWorkingDays = Null
Else
DisplayMessage &quot;Please report 'TR calc error - &quot; & Err.number & &quot; &quot; & Err.Description & &quot; '&quot;
End If
End Function

Thanks to all who helped with this (couldn't of done otherwise) !!!