• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 261
  • Last Modified:

6 months worth of date intervals based on initial date and 2 fields of days of week

Ok...i already have a system in place but it's not exactly what i'm looking for.

ok here's my code:

-------------------------------------------------start of code---------------------------------------
Option Compare Database
Option Explicit

Private Sub InsertDates(StartDate, EndDate, Interval, StartDate2, EndDate2, Interval2)
'delete the contents of the table first
'CurrentDb.Execute "delete * from tblDates"
Dim iSql As String, schDate, schDate2
Dim intPatientid As String, ptid
Do Until schDate >= EndDate
ptid = Me.cmdpatient
    If Not IsDate(schDate) Then
    iSql = "insert into tblDates(dDate,patientid,ddate2) "
    iSql = iSql & "Values(#" & StartDate & "#," & ptid & ",#" & StartDate2 & "#)"
    CurrentDb.Execute iSql
    schDate = DateAdd("d", Interval, StartDate)
    schDate2 = DateAdd("d", Interval2, StartDate2)
   
    Else
    iSql = "insert into tblDates(dDate,patientid,ddate2) "
    iSql = iSql & "Values(#" & schDate & "#," & ptid & ",#" & schDate2 & "#)"
    CurrentDb.Execute iSql
    schDate = DateAdd("d", Interval, schDate)
    schDate2 = DateAdd("d", Interval2, schDate2)
       

   
    End If
Loop
End Sub

Function GetDate(sDay As String) As Date
Dim i As Integer, j As Integer
j = Weekday(Date)
Select Case sDay
    Case "Sunday"
        i = 1
        GetDate = Date - (j - i)
    Case "Monday"
        i = 2
        GetDate = Date - (j - i)
       
    Case "Tuesday"
        i = 3
        GetDate = Date - (j - i)
    Case "Wednesday"
        i = 4
        GetDate = Date - (j - i)
    Case "Thursday"
        i = 5
        GetDate = Date - (j - i)
    Case "Friday"
        i = 6
         GetDate = Date - (j - i)
   Case "Saturday"
        i = 7
        GetDate = Date - (j - i)
End Select
End Function

Private Sub Command3_Click()
DoCmd.OpenTable "tbldates", acViewNormal
End Sub

Private Sub Command4_Click()
'MsgBox Weekday(Date)
Dim msg As String
Dim response As Integer
Me.ComboDay.SetFocus
'MsgBox Me.Comboday2.Value
Me.cmdpatient.SetFocus
msg = "You are about to give " & Me.cmdpatient.Text & " his/her dates for 6 months"
msg = msg & "are you sure you want to continue?"
If MsgBox(msg, vbQuestion + vbYesNo) = vbNo Then
response = acDataErrContinue
       Else
Dim vDate As Date, i As Integer
Dim vdate2 As Date
vDate = GetDate(Me.ComboDay)
vdate2 = GetDate(Me.Comboday2)
Call InsertDates(vDate, DateAdd("m", 6, vDate), 7, vdate2, DateAdd("m", 6, vdate2), 7)

MsgBox "Command Complete.", vbCritical
 End If
End Sub

-------------------------------------------------end of code---------------------------------------

The problem is that i have a need for an initial date to be calculated in.  
So in the "getdate" function the date used is the weekday(date) but i need it to be the initial startdate....

I don't know how to go about this.

chris
0
candg
Asked:
candg
  • 5
  • 5
1 Solution
 
nico5038Commented:
Did you try to add the initial  date as additional parameter like:

Function GetDate(sDay As String, iDate as Date) As Date
Dim i As Integer, j As Integer
j = Weekday(iDate)
Select Case sDay
    Case "Sunday"
        i = 1
        GetDate = iDate - (j - i)
    Case "Monday"
etc.

Nic;o)
0
 
bobHackerCommented:

Hi

This is just a variation on what you have already strated and     nico's comment
but it allows setting the weekend date  or any data as a startdate
hope this helps

Option Compare Database
Option Explicit

Public Function getWeekEndingDate() As Date

Dim dayOfWeek As Integer
Dim dteWeekEndingDate As Date
Dim DayOfWeekEnding As Integer

''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Set the day that the week ends here
'
'sun 1  , mon 2, tue 3, wed 4, thu 5, fri 6, sat 7
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
DayOfWeekEnding = 6   '<<<<<<<<<<<<<<<<<<<<< SET THIS # to 7 if saturday becomes end of week...

'how it works
'if week ending day of week = 6(fri) and today dow=1 (6-1=+5)  5=number of days to add to current day nbr to get to day 6
'if week ending day of week = 6(fri) and today dow=2 (6-2=+4)  4=number of days to add to current day nbr to get to day 6
'if week ending day of week = 6(fri) and today dow=3 (6-3=+3)  3=number of days to add to current day nbr to get to day 6
'if week ending day of week = 6(fri) and today dow=4 (6-4=+2)  2=number of days to add to current day nbr to get to day 6
'if week ending day of week = 6(fri) and today dow=5 (6-5=+1)  1=number of days to add to current day nbr to get to day 6
'if week ending day of week = 6(fri) and today dow=6 (6-6=0)   0=number of days to add to current day nbr to get to day 6
'if week ending day of week = 6(fri) and today dow=7 (6)       6=number of days to add to get to next week day 6


dayOfWeek = Weekday(Date)
'MsgBox "Day of week is: " & dayOfWeek
'MsgBox "Day of weekEnding is: " & dayOfWeek

Select Case dayOfWeek
       Case 1 'sun
            dteWeekEndingDate = DateAdd("d", (DayOfWeekEnding - 1), Date)
       Case 2 'mon
            dteWeekEndingDate = DateAdd("d", (DayOfWeekEnding - 2), Date)
       Case 3 'tue
            dteWeekEndingDate = DateAdd("d", (DayOfWeekEnding - 3), Date)
       Case 4 'wed
            dteWeekEndingDate = DateAdd("d", (DayOfWeekEnding - 4), Date)
       Case 5 'thu
            dteWeekEndingDate = DateAdd("d", (DayOfWeekEnding - 5), Date)
       Case 6 'fri
            dteWeekEndingDate = DateAdd("d", (DayOfWeekEnding - 6), Date)
       Case 7 'sat
            dteWeekEndingDate = DateAdd("d", (DayOfWeekEnding), Date)
       Case Else
            dteWeekEndingDate = Date
End Select

'return
getWeekEndingDate = dteWeekEndingDate

End Function

=========================================================

Public Function getWkEnd7() As Date

      getWkEnd7 = getWeekEndingDate

End Function

Public Function getWkBeg7() As Date

      getWkBeg7 = DateAdd("d", (-6), getWeekEndingDate)

End Function

Public Function getWkEnd14() As Date

      getWkEnd14 = DateAdd("d", (-7), getWeekEndingDate)

End Function

Public Function getWkBeg14() As Date

      getWkBeg14 = DateAdd("d", (-13), getWeekEndingDate)

End Function

Public Function getWkEnd21() As Date

      getWkEnd21 = DateAdd("d", (-14), getWeekEndingDate)

End Function

Public Function getWkBeg21() As Date

      getWkBeg21 = DateAdd("d", (-20), getWeekEndingDate)

End Function

Public Function getWkEnd28() As Date

      getWkEnd28 = DateAdd("d", (-21), getWeekEndingDate)

End Function

Public Function getWkBeg28() As Date

      getWkBeg28 = DateAdd("d", (-27), getWeekEndingDate)

End Function

Public Function getWkEnd35() As Date

      getWkEnd35 = DateAdd("d", (-28), getWeekEndingDate)

End Function

Public Function getWkBeg35() As Date

      getWkBeg35 = DateAdd("d", (-34), getWeekEndingDate)

End Function

Public Function getWkEnd42() As Date

      getWkEnd42 = DateAdd("d", (-35), getWeekEndingDate)

End Function

Public Function getWkBeg42() As Date

      getWkBeg42 = DateAdd("d", (-41), getWeekEndingDate)

End Function
 
0
 
candgAuthor Commented:
bob is there anyway you can put that into a db an send it to me?

deftoned at swbell dot net
0
Configuration Guide and Best Practices

Read the guide to learn how to orchestrate Data ONTAP, create application-consistent backups and enable fast recovery from NetApp storage snapshots. Version 9.5 also contains performance and scalability enhancements to meet the needs of the largest enterprise environments.

 
bobHackerCommented:

Hi,

I am not sure how to do send you a file on here.

BUT...

You could just open up Access and then a new module, and copy and paste the code as is.

Sound OK?
 
thanks
0
 
candgAuthor Commented:
Well...you just email a zipped db......with that code.....so i can see what your saying.

Chris
p.s. points increased to 500
0
 
bobHackerCommented:
Hi Chris,

I have a DB zipped up and ready to send.
What is your email address?

thank you
Bob
0
 
candgAuthor Commented:
deftoned at swbell dot net
0
 
candgAuthor Commented:
bob  hacker what's going on.
0
 
bobHackerCommented:
Hi Chris,

I am sorry.
I got messages from expert exchange via email, and they fell into my spam filter.
I will send you an Access 2002 db with the code in a module. From there you can
run each of the procedures to see if this can be of use to you for your project.

Thank you
Bob
0
 
candgAuthor Commented:
Bob how would i go about calling that in a form?

chris
0
 
bobHackerCommented:
Hi Chris,

You could create a test form with a button just for testing how to call a function.

 ...in the click event for the button do something like this :

============================================================
Private Sub Command0_Click()

Dim theDate As Date

theDate = getWeekEndingDate()     ' this is the call to execute the function
                                                   ' and put the week ending date into this local
                                                   ' variable called theDate
                                   
MsgBox "The week ending date from the function is: " & theDate, vbInformation, "The Date"
                         
                                                                              'this is the variable with the date
                                                                              'that will show up in the message box
 
End Sub
=============================================================
0

Featured Post

How to Use the Help Bell

Need to boost the visibility of your question for solutions? Use the Experts Exchange Help Bell to confirm priority levels and contact subject-matter experts for question attention.  Check out this how-to article for more information.

  • 5
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now