Solved

VBA code for Date splitting

Posted on 2012-04-12
18
494 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 9
  • 6
  • 3
18 Comments
 
LVL 50

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
PeopleSoft Has Never Been Easier

PeopleSoft Adoption Made Smooth & Simple!

On-The-Job Training Is made Intuitive & Easy With WalkMe's On-Screen Guidance Tool.  Claim Your Free WalkMe Account Now

 

Author Comment

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

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 50

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 50

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 50

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 50

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

Technology Partners: 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!

Question has a verified solution.

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

I see at least one EE question a week that pertains to using temporary tables in MS Access.  But surprisingly, I was unable to find a single article devoted solely to this topic. I don’t intend to describe all of the uses of temporary tables in t…
Did you know that more than 4 billion data records have been recorded as lost or stolen since 2013? It was a staggering number brought to our attention during last week’s ManageEngine webinar, where attendees received a comprehensive look at the ma…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…

739 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