Solved

VBA code for Date splitting

Posted on 2012-04-12
18
493 Views
Last Modified: 2012-04-12
Hi,

I am trying to get a piece of code in vba to work. Essentially what it does is split the start and end dates into number of days in each month. It also discounts holidays and weekends. It works mostly fine except when it comes to the last month for each record. The month is recorded wrongly which results in the last month coming up twice.

The data source is attached in the excel file. The destination file contains 4 fields.
Opportunity(text)
Date_code(date)
Monthyear(text)
days_per(number)
Version of Access is 2007

The vba code is given below.

Private Sub PhaseOpps_Click()
DoCmd.SetWarnings (False)

  varInput = "Opps"
  varOutput = "stay_table"
  Call stay_duration(varInput, varOutput)
  DoCmd.SetWarnings (True)
  Set varInput = Nothing
  Set varOutput = Nothing
  
End Sub

Option Compare Database

Public Sub stay_duration(sIn As Variant, sOut As Variant)
On Error GoTo err_report

Dim db As DAO.Database
Dim tblnew As DAO.tabledef
Dim tbl As DAO.Recordset, rst As DAO.Recordset

Dim days_per As Integer, month_hold As Integer
Dim start_date As Date, release_date As Date
Dim year_num As Double, x As Double, y As Double, hold_date As Date
Dim month_name As String, output_table As String, patient_id As String
Dim body As Variant
Dim HolidaysList() As Long
Dim ArrMember As Variant
Dim bWasFound As Boolean

bWasFound = False

HolidayList = Array("27/12/2010", "28/12/2010", "03/01/2011", "22/04/2011", "25/04/2011", "29/04/2011", "02/05/2011", "30/05/2011", "29/08/2011", "26/12/2011", "27/12/2011", "02/01/2012", "06/04/2012", "09/04/2012", "07/05/2012", "04/06/2012", "05/06/2012", "27/08/2012")

Set db = CurrentDb


main:
  output_table = sOut
  DoCmd.DeleteObject acTable, output_table
  Set tblnew = db.CreateTableDef(output_table)
  With tblnew
    .Fields.Append .CreateField("Opportunity", dbText)
    .Fields.Append .CreateField("date_code", dbDate)
    .Fields.Append .CreateField("monthyear", dbText)
    .Fields.Append .CreateField("days_per", dbLong)
  End With
  db.TableDefs.Append tblnew
  body = "Select * from " & sIn
'  body = body & ("select *")
'  body = body & (" ")
'  body = body & ("from Opps;")
  Set rst = db.OpenRecordset(body)
  
  Do Until rst.EOF
  
    start_date = rst.Fields!DateForecastStart
    release_date = rst.Fields!DateOppEnd
    
    x = (release_date - start_date) + 1
    
    month_hold = Month(start_date)
    
    hold_date = start_date
    days_per = 0
    For y = 0 To x - 1
      days_per = 0
      Do While Month(hold_date) = month_hold
            If Weekday(hold_date, vbMonday) < 6 Then
                For Each ArrMember In HolidayList
                    If Format(ArrMember, "dd/mm/yyyy") = Format(hold_date, "dd/mm/yyyy") Then
                        bWasFound = True
                        hold_date = hold_date + 1
                            Exit For
                        Else
                            bWasFound = False
                    End If
                Next ArrMember
                    If bWasFound = False Then
                        days_per = days_per + 1
                        hold_date = hold_date + 1
                    End If
              Else
                    hold_date = hold_date + 1
              End If
            y = y + 1
        
        Select Case y
          Case Is > x - 1
            hold_date = DateSerial(Year(hold_date), Month(hold_date) + 1, 1)
            Exit Do
          
        End Select
        
   
      Loop

      y = y - 1
      Set tbl = db.OpenRecordset(output_table, dbOpenDynaset)
      datecode = DateSerial(Year(hold_date), Month(hold_date) - 1, 1)
      With tbl
        .AddNew
        .Fields(0) = rst.Fields!Opportunity
        .Fields(1) = datecode
        .Fields(2) = Format((datecode), "yyyy") & " " & Format((datecode), "mm")
        .Fields(3) = days_per
        .Update
      End With
      month_hold = Month(hold_date)
    Next y

    rst.MoveNext
  Loop
  GoTo exit_sub

err_report:
  Select Case Err.Number
    Case 7874
      Resume Next
    Case Else
      MsgBox Err.Number & vbCrLf & Err.Description
      GoTo exit_sub
  End Select
    
exit_sub:
  End Sub

Open in new window

0
Comment
Question by:trentbridge
  • 9
  • 6
  • 3
18 Comments
 
LVL 49

Expert Comment

by:Gustav Brock
ID: 37837201
Your holidays list is not dates. Change to:

Dim HolidaysList() As Long
HolidayList = Array(#12/27/2010#, #12/28/2010#, .. etc.

Also:

 If DateDiff("d", ArrMember, hold_date) = 0 Then

/gustav
0
 
LVL 47

Expert Comment

by:Dale Fye (Access MVP)
ID: 37837221
What does the actual data look like (no file attached).  What are the range of dates between the start and end dates, they obviously span multiple months, but are the on the order of 90 days, a year, or longer?

What do you want to t output to look like?

I generally do  this via a query, but that requires that your holiday dates be in a table, not an array (which is actually better because then you don't have to change your code every year.  If you provide some sample input and output, I'll see if I can resurrect the query I use for that and post it back
0
 

Author Comment

by:trentbridge
ID: 37837250
Sorry forgot to attach sample data. Would prefer if the procedure is in vba. but open to other better solutions
Opps.xlsx
stay-table.xlsx
0
Use Case: Protecting a Hybrid Cloud Infrastructure

Microsoft Azure is rapidly becoming the norm in dynamic IT environments. This document describes the challenges that organizations face when protecting data in a hybrid cloud IT environment and presents a use case to demonstrate how Acronis Backup protects all data.

 

Author Comment

by:trentbridge
ID: 37837277
@gustav After changing the code to what you suggested, it gives me type mismatch
0
 
LVL 49

Expert Comment

by:Gustav Brock
ID: 37837328
I guess so. Not knowing whery you encounter the mismatch, you will have to walk through your code and adjust.

/gustav
0
 

Author Comment

by:trentbridge
ID: 37837343
when I took off the # from the date array. it works
0
 

Author Comment

by:trentbridge
ID: 37837375
But my main issue remains unresolved.
See here

Opportunity      date_code      monthyear      days_per
7474232      01/01/2012      2012 01            12
7474232      01/02/2012      2012 02            21
7474232      01/03/2012      2012 03            22
7474232      01/04/2012      2012 04            19
7474232      01/05/2012      2012 05            22
7474232      01/06/2012      2012 06            19
7474232      01/07/2012      2012 07            22
7474232      01/08/2012      2012 08            22
7474232      01/09/2012      2012 09            20
7474232      01/10/2012      2012 10            23
7474232      01/11/2012      2012 11            22
7474232      01/01/2013      2013 01            21

Instead of 2013 01 for the last record. it shows 2013 01. It skips one month
0
 

Author Comment

by:trentbridge
ID: 37837390
I have a feeling that the problem area is this part

     Select Case y
          Case Is > x - 1
            hold_date = DateSerial(Year(hold_date), Month(hold_date) + 1, 1)
            Exit Do
          
        End Select

Open in new window

0
 
LVL 49

Expert Comment

by:Gustav Brock
ID: 37837432
> when I took off the # from the date array. it works

No. The error just vanished, I guess.

> But my main issue remains unresolved.

Yes. You have to be very strict handling dates as dates and not as strings.

My I suggest you reveal where the error occur?

/gustav
0
 
LVL 47

Accepted Solution

by:
Dale Fye (Access MVP) earned 500 total points
ID: 37837448
My SQL solution to this is shown in the attached database.

The final query is shown as: qry_Date_Count_Between_two_dates_by_month_wo_Holiday_and_Weekend.

The way I came up with this is sequentially:
1.  qry_Dates_Between_Two_Dates
2.  qry_Dates_Between_two_Dates_w_Holiday_and_Weekend
3.  qry_Dates_Between_two_Dates_wo_Holiday_and_Weekend

and then the final query.  You only really need query #1 and the final query to implement this in your database.  All you need to do is modify this to make it in Append query and append the values to your destination table.  Hope this helps.
DaysPerMonth.mdb
0
 
LVL 49

Expert Comment

by:Gustav Brock
ID: 37837485
Oops, of course you should use:

Dim HolidaysList() As Date

But, as you use Array(), you must use a Variant:

Dim HolidaysList  As Variant
HollidayList = Array(# ...#, ...)

/gustav
0
 

Author Comment

by:trentbridge
ID: 37837621
@gustav I have run this procedure without the holiday list and still the issue I have is as I mentioned earlier. Personally I have checked by stepping throught the code that the array works without putting #.

My main issue is the months not being assigned properly.
0
 

Author Comment

by:trentbridge
ID: 37837639
@fyed Your solution works brilliantly but because it's query based I will have to re work most of my script. I will wait till tomorrow, if any one comes up with a vba solution. If nothing comes along, I guess, I will have to roll up my sleeves and start changing everything.
0
 
LVL 49

Expert Comment

by:Gustav Brock
ID: 37837752
> .. the array works without putting #.

That may be so but it is not how to do it.
Also, your looping seems a bit convoluted to me.

/gustav
0
 

Author Comment

by:trentbridge
ID: 37837775
@gustav

> ..Also, your looping seems a bit convoluted to me.

Well that's exactly the reason why I am here. I am no great coder. So would be grateful if some one points me in the right direction.
0
 
LVL 49

Expert Comment

by:Gustav Brock
ID: 37837887
For each month, I would first count to total days excluding weekends to get the max. count of workdays for the month.
Then count the holidays picking those for the current month which do not fall in weekends.
Finally, subtract the holidays' count from the workdays.

/gustav
0
 

Author Closing Comment

by:trentbridge
ID: 37838365
Thanks very much for your quick and timely response
0
 
LVL 47

Expert Comment

by:Dale Fye (Access MVP)
ID: 37838443
Glad to help.

I had used that database sample a while back to answer a similar question, just had to add in your holidays table. and modify the queries accordingly.
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Overview: This article:       (a) explains one principle method to cross-reference invoice items in Quickbooks®       (b) explores the reasons one might need to cross-reference invoice items       (c) provides a sample process for creating a M…
As tax season makes its return, so does the increase in cyber crime and tax refund phishing that comes with it
In Microsoft Access, when working with VBA, learn some techniques for writing readable and easily maintained code.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

820 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