?
Solved

VBA for calculation of dates and showing a warning etc.

Posted on 2012-09-10
23
Medium Priority
?
747 Views
Last Modified: 2012-09-13
I hope I can get a quick answer to why my code is not working. To give you the back ground in my database application, I need to take a date field and a data size gb fields to determine how quickly to process the data in business days.

So for example, I have the following fields:

Data_Size_GB as Double
Date_Received as Date
Expected_Delivery as Date
SLA_Expectation As Text
SLA_Status As Text

We have a specialized software for the legal industry so we can get native files such as emails, word, excel, etc. so this access db is tracking all of the vital information that we have to report back to our client on a weekly basis. So we fill-out our database form with the Date Received (when we receive the new data load request), Data Size (GB) based on these two fields, we need to determine how many business days, it will take us to complete the dataload per the client's SLA (expectations).

So, if I get a dataload today 09/10/2012 and it is 5.00 GB then I would need to add 3 days to Date_Received to update the Expected_Delivery field of when it is due and I have the SLA_Expectation would fill in with the particular SLA that meets the data and date received fields = Three (3) work-days after receipt of the media. The SLA_Status will be based on whether we Beat, Meet or Fail the 3 days that compares the Expected_Delivery field with the Date_Available field.   When calculating the Expected Delivery, we need to make sure that we do not count any weekends and holidays since it is business days.

Here is my code so far:

Private Sub Expected_Delivery_AfterUpdate()

Dim dataSizeGB As Double
Dim dueDate As Date

Me.Data_Size_GB = dataSizeGB

If (dataSizeGB < 1) Then
    dueDate = DateSerial(Month([Date_Received]), Day([Date_Received] + 1), Year([Date_Received]))
    dueDate = Me.Expected_Delivery
ElseIf (dataSizeGB > 1 < 5) Then
    dueDate = DateSerial(Month([Date_Received]), Day([Date_Received] + 3), Year([Date_Received]))
    dueDate = Me.Expected_Delivery
ElseIf (dataSizeGB > 5 < 20) Then
    dueDate = DateSerial(Month([Date_Received]), Day([Date_Received] + 5), Year([Date_Received]))
    dueDate = Me.Expected_Delivery
ElseIf (dataSizeGB > 20 < 100) Then
    dueDate = DateSerial(Month([Date_Received]), Day([Date_Received] + 8), Year([Date_Received]))
    dueDate = Me.Expected_Delivery
ElseIf (dataSizeGB > 100 < 300) Then
    dueDate = DateSerial(Month([Date_Received]), Day([Date_Received] + 15), Year([Date_Received]))
    dueDate = Me.Expected_Delivery
ElseIf (dataSizeGB > 300) Then
    MsgBox "Please contact the SEC POC and Enter Expected Delivery Date", vbOKOnly
End If
 
End Sub

I really need help. Thanks.
0
Comment
Question by:lauriecking0623
  • 12
  • 8
  • 3
23 Comments
 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 38383663
use this format for calculating the due date


dueDate = DateSerial(Year([Date_Received]), Month([Date_Received]), Day([Date_Received] + 1))
0
 

Author Comment

by:lauriecking0623
ID: 38383681
@capricorn1

I made the change; however, it still does not update the Expected_Delivery Date yet.

Plus I want it to use the business days as well. I have a function for calculating the business days that I can use.
0
 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 38383723
use

Private Sub Date_Received_AfterUpdate()  

event to update the Expected_Delivery Date

instead of

Private Sub Expected_Delivery_AfterUpdate()


Private Sub Date_Received_AfterUpdate()  

Dim dataSizeGB As Double
Dim dueDate As Date

Me.Data_Size_GB = dataSizeGB

If (dataSizeGB < 1) Then
    dueDate = DateSerial(Year([Date_Received]), Month([Date_Received]), Day([Date_Received] + 1))

   ' all the other conditions here

end if

me.Expected_Delivery=dueDate

end sub
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:lauriecking0623
ID: 38383771
It will give me the calculated date; however, when I have more than 1 GB entered, it still adds only one day even those it is over 1.5 so it should add 3 business days.

How could I add the business days? I have a function but I am not sure how to incorporate it in this code?

Here is the code:

Option Compare Database
Option Explicit

Function Work_Days(BegDate As Variant, EndDate As Variant) As Integer

'"Calculating the workdays between Dates"
'Note that this function does account for holidays

Dim WholeWeeks As Variant
Dim DateCnt As Variant
Dim EndDays As Integer

BegDate = DateValue(BegDate)
EndDate = DateValue(EndDate)
DateCnt = BegDate
EndDays = 0

Do While DateCnt <= EndDate

If Not IsNull(DLookup("Holiday_Date", "TBL_Holidays", "[Holiday_Date]=#" & DateCnt & "#")) Then
EndDays = EndDays - 1
End If

If Format(DateCnt, "ddd") <> "Sun" And _
Format(DateCnt, "ddd") <> "Sat" Then
EndDays = EndDays + 1
DateCnt = DateAdd("d", 1, DateCnt)
Loop
Work_Days = EndDays


End Function
0
 
LVL 52

Accepted Solution

by:
Gustav Brock earned 2000 total points
ID: 38383790
Here is what you need to do:
Dim intDays As Integer
' NB:
dataSizeGB = Me.Data_Size_GB 

Select Case dataSizeGB
  Case < 1
    intDays = 1
  Case < 5
    intDays = 3
  Case < 20
    intDays = 5
  Case < 100
    intDays = 8
  Case < 300
    intDays = 15
  Case Else
    MsgBox "Please contact the SEC POC and Enter Expected Delivery Date", vbOKOnly
End Select

 Me.Expected_Delivery = DateAdd("d", intDays, [Date_Received]) 

Open in new window

/gustav
0
 

Author Comment

by:lauriecking0623
ID: 38383845
@cactus_data,

That works. I would like to make sure not to include the weekend days and holidays. I have the holidays in a table. I have posted my function above. What is your suggestion?
0
 
LVL 120

Expert Comment

by:Rey Obrero (Capricorn1)
ID: 38383934
<it still adds only one day even those it is over 1.5 so it should add 3 business days.>



If (dataSizeGB < 1) Then
    dueDate = DateSerial(Year([Date_Received]), Month([Date_Received]), Day([Date_Received] + 1))

  ' all the other conditions here  '<<did you read this part

end if
0
 

Author Comment

by:lauriecking0623
ID: 38383952
@capricorn1,

yes, I put the other conditions into my code. It did not work for some reason. I think that the Select...Case works the best since it works.

@cactus_data:

I changed it to the Select Case. It works great just need to be able to put in my code that I created for work days so when the calculation is done that it does not include the weekends and holidays ("non-business") days.

Once that is done, this would be perfect.
0
 
LVL 52

Assisted Solution

by:Gustav Brock
Gustav Brock earned 2000 total points
ID: 38384006
I use the function below to replace DateAdd.
Public Function ISO_WorkdayAdd( _
  ByVal datDateFrom As Date, _
  ByVal lngWorkdaysAdd As Long, _
  Optional ByVal bytWorkdaysOfWeek As Byte = 5, _
  Optional ByVal booExcludeHolidays As Boolean) _
  As Date

' Purpose: Add number of working days to date datDateFrom.
' Assumes: 1 to 7 working days per week.
'          First workday is Monday.
'          Weekend is up to and including Sunday.
' Requires: ISO_WorkdayDiff
'           DateSkipWeekend
' May be freely used and distributed.
'
' 1999-04-23. Gustav Brock, Cactus Data ApS, Copenhagen
' 2000-10-03. Constants added.
'             Option for 5 or 6 working days per week added.
' 2002-01-10. Option for 1 to 7 working days per week added.
'             Allowed to add negative number of working days.
'             Adding of zero working days returns the next
'             working day if current day is not a working day.
' 2008-06-14. Option to add holidays in the period to the count of workdays.
' 2011-03-23. Included a call to DateSkipWeekend to calculate correctly for a
'             holiday ending right before a weekend at the end of the period.
'
' Test:
' For j = 0 To 10 : For i = 0 to 12 : ? j, i, ISO_WorkdayAdd(Date + j, i): Next i: Next j

  ' Minimum and maximum count of workdays per week.
  Const cbytWorkdaysCountMin  As Byte = 1
  Const cbytWorkdaysCountMax  As Byte = 7

  Dim datDateTo               As Date
  Dim bytMonday               As Byte
  Dim bytSunday               As Byte
  Dim intWeekdayFirst         As Integer
  Dim intWorkdayLast          As Integer
  Dim intDaysShift            As Integer
  Dim lngDays                 As Long
  Dim lngWeeks                As Long
  Dim lngWorkdays             As Long
  Dim lngWorkdaysDiff         As Long
  
  On Error GoTo Err_ISO_WorkdayAdd
  
  datDateTo = datDateFrom
  lngWorkdays = lngWorkdaysAdd
  If bytWorkdaysOfWeek >= cbytWorkdaysCountMin And bytWorkdaysOfWeek <= cbytWorkdaysCountMax Then
    ' Find ISO weekday for Monday.
    bytMonday = Weekday(vbMonday, vbMonday)
    ' Find ISO weekday for Sunday.
    bytSunday = Weekday(vbSunday, vbMonday)
    ' Find ISO weekday for last workday.
    intWorkdayLast = bytMonday + bytWorkdaysOfWeek - 1
    
    ' Find ISO weekday for date datDateTo.
    intWeekdayFirst = Weekday(datDateTo, vbMonday)
    ' Shift date datDateTo from weekend to Monday.
    If intWeekdayFirst > intWorkdayLast Then
      If lngWorkdaysAdd >= 0 Then
        datDateTo = DateAdd("d", bytSunday - intWeekdayFirst + 1, datDateTo)
      Else
        datDateTo = DateAdd("d", intWorkdayLast - intWeekdayFirst, datDateTo)
      End If
      ' Find ISO weekday for shifted date datDateTo.
      intWeekdayFirst = Weekday(datDateTo, vbMonday)
    End If
    
    ' Calculate number of days date datDateTo shall be shifted.
    If lngWorkdaysAdd >= 0 Then
      ' Shift to proceeding Monday in current week.
      intDaysShift = intWeekdayFirst - bytMonday
    Else
      ' Shift to succeeding last workday in current week.
      intDaysShift = intWeekdayFirst - intWorkdayLast
    End If
    ' Shift date datDateTo.
    datDateTo = DateAdd("d", -intDaysShift, datDateTo)
    ' Calculate workdays to add from start/end of current work week.
    lngWorkdaysAdd = lngWorkdaysAdd + intDaysShift
    
    ' Calculate number of workweeks and additional workdays to add.
    lngWeeks = lngWorkdaysAdd \ bytWorkdaysOfWeek
    lngDays = lngWorkdaysAdd Mod bytWorkdaysOfWeek
    
    ' Add number of calendar weeks and additional calendar days to
    ' shifted date datDateTo.
    If lngWeeks <> 0 Then
      datDateTo = DateAdd("ww", lngWeeks, datDateTo)
    End If
    If lngDays <> 0 Then
      datDateTo = DateAdd("d", lngDays, datDateTo)
    End If
    
    If booExcludeHolidays = True Then
      While lngWorkdays - lngWorkdaysDiff > 0
        lngWorkdaysDiff = ISO_WorkdayDiff(datDateFrom, datDateTo, True)
        datDateTo = DateAdd("d", lngWorkdays - lngWorkdaysDiff, datDateTo)
        datDateTo = DateSkipWeekend(datDateTo)
      Wend
    End If

  End If
  
  ISO_WorkdayAdd = datDateTo
  
Exit_ISO_WorkdayAdd:
  Exit Function
  
Err_ISO_WorkdayAdd:
  ' Date datDateTo + lngWorkdaysAdd is outside date range of Access.
  ' Return time zero, 00:00:00.
  Resume Exit_ISO_WorkdayAdd

End Function


Public Function ISO_WorkdayDiff( _
  ByVal datDateFrom As Date, _
  ByVal datDateTo As Date, _
  Optional ByVal booExcludeHolidays As Boolean) _
  As Long

' Purpose: Calculate number of working days between dates datDateFrom and datDateTo.
' Assumes: 5 or 6 working days per week. Weekend is (Saturday and) Sunday.
' May be freely used and distributed.

' 1999-04-23. Gustav Brock, Cactus Data ApS, Copenhagen
' 2000-10-03. Constants added.
'             Option for 5 or 6 working days per week added.
' 2008-06-12. Option to exclude holidays from the count of workdays.
' 2011-06-08. Rewrite using Skip functions.

  Const cbytWorkdaysOfWeek  As Byte = 5
  ' Name of table with holidays.
  Const cstrTableHoliday    As String = "tblHoliday"
  ' Name of date field in holiday table.
  Const cstrFieldHoliday    As String = "HolidayDate"

  Dim booReverse            As Boolean
  Dim booSameWeekend        As Boolean
  Dim lngWeeks              As Long
  Dim lngDays               As Long
  Dim lngHolidays           As Long
  Dim lngWorkdays           As Long
  Dim strDateFrom           As String
  Dim strDateTo             As String
  Dim strFilter             As String
  
  If Weekday(datDateFrom, vbMonday) > cbytWorkdaysOfWeek And _
    Weekday(datDateTo, vbMonday) > cbytWorkdaysOfWeek Then
    ' Both dates are of the same weekend.
    booSameWeekend = True
  End If
  
  Select Case DateDiff("d", datDateFrom, datDateTo)
    Case 0
      ' Zero days.
      Exit Function
    Case 1
      If booSameWeekend Then
        ' Both dates are of the same weekend.
        Exit Function
      End If
    Case -1
      If booSameWeekend Then
        ' Both dates are of the same weekend.
        Exit Function
      Else
        booReverse = True
      End If
    Case Is < -1
      ' Negative count.
      booReverse = True
    Case Else
      ' Positive count.
  End Select
    
  ' Adjust dates to skip weekends and holidays.
  datDateFrom = DateSkipNoneWorkingday(datDateFrom, booReverse)
  datDateTo = DateSkipNoneWorkingday(datDateTo, Not booReverse)
  
  ' Find count of full weeks.
  lngWeeks = DateDiff("w", datDateFrom, datDateTo)
  ' Calculate number of working days between the two weekdays ignoring holidays.
  lngDays = Weekday(datDateTo, vbMonday) - Weekday(datDateFrom, vbMonday) _
    + cbytWorkdaysOfWeek * DateDiff("ww", DateAdd("ww", lngWeeks, datDateFrom), datDateTo, vbMonday)
  
  If booExcludeHolidays Then
    strDateFrom = Format(datDateFrom, "yyyy\/mm\/dd")
    strDateTo = Format(datDateTo, "yyyy\/mm\/dd")
    strFilter = cstrFieldHoliday & " Between #" & strDateFrom & "# And #" & strDateTo & "# And Weekday(" & cstrFieldHoliday & ", 2) <= " & cbytWorkdaysOfWeek & ""
    lngHolidays = IIf(booReverse, -1, 1) * DCount("*", cstrTableHoliday, strFilter)
  End If
  ' Add number of working days between the weeks of the two dates.
  ' Deduct count of holidays.
  lngWorkdays = lngDays + cbytWorkdaysOfWeek * lngWeeks - lngHolidays
  
  ISO_WorkdayDiff = lngWorkdays

End Function


Public Function DateSkipNoneWorkingday( _
  ByVal datDate As Date, _
  Optional ByVal booReverse As Boolean) _
  As Date

' Purpose: Calculate first working day following/preceding datDate.
'
' 2009-04-12. Gustav Brock, Cactus Data ApS, Copenhagen

  
  Dim datNext As Date
  Dim datTest As Date
    
  datNext = datDate
  Do
    datTest = datNext
    datNext = DateSkipHoliday(datTest, booReverse)
    datNext = DateSkipWeekend(datNext, booReverse)
  Loop Until DateDiff("d", datTest, datNext) = 0
  
  DateSkipNoneWorkingday = datNext

End Function


Public Function DateSkipHoliday( _
  ByVal datDate As Date, _
  Optional ByVal booReverse As Boolean) _
  As Date

' Purpose: Calculate first day following/preceding datDate if this is holiday.
'
' 2009-04-12. Gustav Brock, Cactus Data ApS, Copenhagen

  ' Adjust to fit your table of holidays.
  Const cstrHolidayTable  As String = "tblHoliday"
  Const cstrHolidayField  As String = "HolidayDate"
  
  While Not IsNull(DLookup(cstrHolidayField, cstrHolidayTable, cstrHolidayField & " = " & Format(datDate, "\#m\/d\/yyyy\#")))
    datDate = DateAdd("d", 1 - Abs(2 * booReverse), datDate)
  Wend

  DateSkipHoliday = datDate

End Function


Public Function DateSkipWeekend( _
  ByVal datDate As Date, _
  Optional ByVal booReverse As Boolean) _
  As Date

' Purpose: Calculate first working day equal to or following/preceding datDate.
' Assumes: 5 or 6 working days per week. Weekend is (Saturday and) Sunday.
' Limitation: Does not count for public holidays.
'
' May be freely used and distributed.
' 1999-07-03, Gustav Brock, Cactus Data ApS, Copenhagen
  
  Const cintWorkdaysOfWeek As Integer = 5

  Dim bytSunday   As Byte
  Dim bytWeekday  As Byte
  
  bytSunday = Weekday(vbSunday, vbMonday)
  bytWeekday = Weekday(datDate, vbMonday)
  
  If bytWeekday > cintWorkdaysOfWeek Then
    ' Weekend.
    If booReverse = False Then
      ' Get following workday.
      datDate = DateAdd("d", 1 + bytSunday - bytWeekday, datDate)
    Else
      ' Get preceding workday.
      datDate = DateAdd("d", cintWorkdaysOfWeek - bytWeekday, datDate)
    End If
  End If

  DateSkipWeekend = datDate

End Function

Open in new window

/gustav
0
 

Author Comment

by:lauriecking0623
ID: 38384055
@Cactus_data:

I added the code as basWorkdays but when I put the ISO Workdays where the DateAdd, it does not work well. Did I put it in right?

Me.Expected_Delivery = DateAdd("d", intDays, [Date_Received])

I put Me.Expected_Delivery = ISO_WorkdayAdd("d", intDays, [Date_Received])

I think it is wrong.
0
 
LVL 52

Expert Comment

by:Gustav Brock
ID: 38384136
No, it is different:

Public Function ISO_WorkdayAdd( _
  ByVal datDateFrom As Date, _
  ByVal lngWorkdaysAdd As Long, _
  Optional ByVal bytWorkdaysOfWeek As Byte = 5, _
  Optional ByVal booExcludeHolidays As Boolean) _
  As Date

Thus:

 = ISO_WorkdayAdd([Date_Received], intDays, , True)

/gustav
0
 

Author Comment

by:lauriecking0623
ID: 38384148
I added it like you suggested but it gives me 12/30/1899 in the Expected Delivery.
0
 

Author Comment

by:lauriecking0623
ID: 38384477
@cactus_data:

I put in the code into the Select Case code; however, when I update the Date_received field, it only puts 12/30/1899 in the Expected_Delivery Field. That is it. Do you know why this is doing that?
0
 
LVL 52

Assisted Solution

by:Gustav Brock
Gustav Brock earned 2000 total points
ID: 38384543
Well, either of the parameters are zero, or try with:

= ISO_WorkdayAdd([Date_Received], intDays, 5, False)

/gustav
0
 

Author Comment

by:lauriecking0623
ID: 38384599
@cactus_data:

I changed it to your suggestion. It gives me a date; however, I have this record that the date_received is 07/03/2012 so since the next day is 07/04/2012 a national holiday, then it should go to 07/05/2012; however, it shows 07/04/2012.

I have a table in my database called Tbl_Holidays with Holiday_Date for the holidays.  I do not know why your code does not take into account the weekend days and holidays.

Is there something I am doing wrong?
0
 
LVL 52

Expert Comment

by:Gustav Brock
ID: 38385598
To take holidays into accent, the last parameter must be True.
Also, the code has to be changed to match your table and field names:

  ' Name of table with holidays.
  Const cstrTableHoliday    As String = "tblHoliday"
  ' Name of date field in holiday table.
  Const cstrFieldHoliday    As String = "HolidayDate"

/gustav
0
 

Author Comment

by:lauriecking0623
ID: 38386790
I did that both things that you have said. It is back to the 12/30/1899 being filled in the Expected_Delivery field.
0
 
LVL 52

Expert Comment

by:Gustav Brock
ID: 38387026
It indicates that you somehow feed the function with zero values and not current dates.

Does this still work:

 Me.Expected_Delivery = DateAdd("d", intDays, [Date_Received])

/gustav
0
 

Author Comment

by:lauriecking0623
ID: 38389544
I will try it in the morning.
0
 

Author Comment

by:lauriecking0623
ID: 38391869
@cactus_data:

I changed it back to the DateAdd and works correctly just does not skip the weekends and holidays.
0
 
LVL 52

Expert Comment

by:Gustav Brock
ID: 38391993
Then, I guess, you somehow have got the code wrong.

If I enter for example:

datNext = ISO_WorkdayAdd(Date, 7)

I receive for datNext:
2012-09-21

which is correct.
You could try to delete and re-copy-paste the functions.

/gustav
0
 

Author Closing Comment

by:lauriecking0623
ID: 38395797
It works great now. The final statement in the code using his Function for keeping out weekends and holidays for my db is

Me.Expected_Delivery = ISO _WorkAdd([Date_Received], intDays, 5, True)

Now things are great!!! Thank you so much!
0
 
LVL 52

Expert Comment

by:Gustav Brock
ID: 38397761
You are welcome! Glad you found out.

/gustav
0

Featured Post

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Instead of error trapping or hard-coding for non-updateable fields when using QODBC, let VBA automatically disable them when forms open. This way, users can view but not change the data. Part 1 explained how to use schema tables to do this. Part 2 h…
Microsoft Access has a limit of 255 columns in a single table; SQL Server allows tables with over 255 columns, but reading that data is not necessarily simple.  The final solution for this task involved creating a custom text parser and then reading…
With Microsoft Access, learn how to specify relationships between tables and set various options on the relationship. Add the tables: Create the relationship: Decide if you’re going to set referential integrity: Decide if you want cascade upda…
With just a little bit of  SQL and VBA, many doors open to cool things like synchronize a list box to display data relevant to other information on a form.  If you have never written code or looked at an SQL statement before, no problem! ...  give i…

749 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question