VBA code for Date splitting

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

trentbridgeAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Gustav BrockCIOCommented:
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
Dale FyeOwner, Developing Solutions LLCCommented:
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
trentbridgeAuthor Commented:
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
Protecting & Securing Your Critical Data

Considering 93 percent of companies file for bankruptcy within 12 months of a disaster that blocked access to their data for 10 days or more, planning for the worst is just smart business. Learn how Acronis Backup integrates security at every stage

trentbridgeAuthor Commented:
@gustav After changing the code to what you suggested, it gives me type mismatch
0
Gustav BrockCIOCommented:
I guess so. Not knowing whery you encounter the mismatch, you will have to walk through your code and adjust.

/gustav
0
trentbridgeAuthor Commented:
when I took off the # from the date array. it works
0
trentbridgeAuthor Commented:
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
trentbridgeAuthor Commented:
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
Gustav BrockCIOCommented:
> 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
Dale FyeOwner, Developing Solutions LLCCommented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Gustav BrockCIOCommented:
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
trentbridgeAuthor Commented:
@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
trentbridgeAuthor Commented:
@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
Gustav BrockCIOCommented:
> .. 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
trentbridgeAuthor Commented:
@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
Gustav BrockCIOCommented:
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
trentbridgeAuthor Commented:
Thanks very much for your quick and timely response
0
Dale FyeOwner, Developing Solutions LLCCommented:
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
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.