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"
EndDate = Format(DateOut, "general date"
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, "0.0"
Exit Function
Else
Newstring = StartDate + 1
Newstring = Left(Newstring, 10) & " 08:00"
Monday = Newstring
HoursToDrop = DateDiff("n", StartDate, Monday)
End If
Case 7
If WeekEnd = 7 Or WeekEnd = 1 And TotalHours < 2880 Then
NonWorkingDays = Format(TotalHours / 60, "0.0"
Exit Function
Else
Newstring = StartDate + 2
Newstring = Left(Newstring, 10) & " 08:00"
Monday = Newstring
HoursToDrop = DateDiff("n", 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 ""
DateCounter = StartDate
Do
If WeekDay(DateCounter) = 7 Or WeekDay(DateCounter) = 1 Then
HoursToDrop = HoursToDrop + 1440
Else
HoliDays = DCount("holidate", "HolidayTable", "holidate = #" & DateCounter & "#"
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("holidate", "HolidayTable", "holidate = #" & DateCounter & "#"
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, "0.0"
Exit Function
CalcError:
If Err.number = 94 Or Err.number = 13 Then
NonWorkingDays = Null
Else
DisplayMessage "TR calc error - " & Err.number & " " & Err.Description
End If
End Function
Any ideas ?
Thanks alot!!
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"
EndDate = Format(DateOut, "general date"
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, "0.0"
Exit Function
Else
Newstring = StartDate + 1
Newstring = Left(Newstring, 10) & " 08:00"
Monday = Newstring
HoursToDrop = DateDiff("n", StartDate, Monday)
End If
Case 7
If WeekEnd = 7 Or WeekEnd = 1 And TotalHours < 2880 Then
NonWorkingDays = Format(TotalHours / 60, "0.0"
Exit Function
Else
Newstring = StartDate + 2
Newstring = Left(Newstring, 10) & " 08:00"
Monday = Newstring
HoursToDrop = DateDiff("n", 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 ""
DateCounter = StartDate
Do
If WeekDay(DateCounter) = 7 Or WeekDay(DateCounter) = 1 Then
HoursToDrop = HoursToDrop + 1440
Else
HoliDays = DCount("holidate", "HolidayTable", "holidate = #" & DateCounter & "#"
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("holidate", "HolidayTable", "holidate = #" & DateCounter & "#"
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, "0.0"
Exit Function
CalcError:
If Err.number = 94 Or Err.number = 13 Then
NonWorkingDays = Null
Else
DisplayMessage "TR calc error - " & Err.number & " " & Err.Description
End If
End Function
Any ideas ?
Thanks alot!!