Solved

VBA code for Date splitting

Posted on 2012-04-12
18
485 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
Comment Utility
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)
Comment Utility
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
Comment Utility
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
 

Author Comment

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

Expert Comment

by:Gustav Brock
Comment Utility
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
Comment Utility
when I took off the # from the date array. it works
0
 

Author Comment

by:trentbridge
Comment Utility
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
Comment Utility
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
Comment Utility
> 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
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 
LVL 47

Accepted Solution

by:
Dale Fye (Access MVP) earned 500 total points
Comment Utility
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
Comment Utility
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
Comment Utility
@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
Comment Utility
@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
Comment Utility
> .. 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
Comment Utility
@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
Comment Utility
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
Comment Utility
Thanks very much for your quick and timely response
0
 
LVL 47

Expert Comment

by:Dale Fye (Access MVP)
Comment Utility
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

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

The first two articles in this short series — Using a Criteria Form to Filter Records (http://www.experts-exchange.com/A_6069.html) and Building a Custom Filter (http://www.experts-exchange.com/A_6070.html) — discuss in some detail how a form can be…
Today's users almost expect this to happen in all search boxes. After all, if their favourite search engine juggles with tens of thousand keywords while they type, and suggests matching phrases on the fly, why shouldn't they expect the same from you…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
What’s inside an Access Desktop Database. Will look at the basic interface, Navigation Pane (Database Container), Tables, Queries, Forms, Report, Macro’s, and VBA code.

728 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

Need Help in Real-Time?

Connect with top rated Experts

8 Experts available now in Live!

Get 1:1 Help Now