'The following assumes two tables:
'#1 "tblMonthData" with three fields
' Customer (type long integer)
' DateFld (type Date/Time) should not name this field 'Date' as that is an Access reserved word
' Qty (type long integer)
'#2 "tblWeekData" with five fields
' Customer (type integer)
' MonthNumber (type byte)
' YearNumber (type long integer)
' WeekNumber (type byte)
' Qty (type long integer)
Public Sub getWeekData()
'adds records to "tblWeekData" for each record in "tblMonthData" unless records are already there
'Week #1 will be the first full week of the month starting on a Sunday
Dim rstMonth As DAO.Recordset 'Table of Month Data
Dim rstWeek As DAO.Recordset 'Table of Week Data
Dim rstTest As DAO.Recordset 'Temporary recordset used to check for existance of records
Dim intDays As Integer 'Days in the month
Dim dtFirstFullWeek As Date 'Date of first full week starting on Sunday
Dim dtValue As Date 'Temporary date value used for calculation
Dim intCounter As Integer 'Week number counter
Set rstMonth = CurrentDb.OpenRecordset("tblMonthData")
Set rstWeek = CurrentDb.OpenRecordset("tblWeekData", dbOpenDynaset)
With rstMonth
Do While Not .EOF
Set rstTest = CurrentDb.OpenRecordset("SELECT tblWeekData.* FROM tblWeekData WHERE (((tblWeekData.Customer)=" & ![Customer] & ") AND ((tblWeekData.Month)=" & Month(![DateFld]) & ") AND ((tblWeekData.Year)=" & Year(![DateFld]) & "))")
If rstTest.EOF Then 'No records found for this customer, month and year, so add new records
rstTest.Close
Set rstTest = Nothing 'free up memory
intCounter = 1 'sets up a counter for the week number
dtValue = CDate(![DateFld]) ' converts value in case your dates are stored as string values and sets up a temporary date value for calculations
intDays = daysInMonth(dtValue)
dtFirstFullWeek = getDateOfFirstFullWeek(dtValue) 'returns date of Sunday of first full week
intCounter = 0 'reset intCounter
Do While Month(dtValue) = Month(CDate(![DateFld])) 'loop while still in the current month, adding a new record for each week
intCounter = intCounter + 1 'increment the week counter by one
rstWeek.AddNew
rstWeek!Customer = ![Customer]
rstWeek!MonthNumber = Month(CDate(![DateFld]))
rstWeek!Year = Year(Month(CDate(![DateFld])))
rstWeek!WeekNumber = intCounter
rstWeek!Qty = (![Qty] / intDays) * 7
rstWeek.Update
dtValue = DateAdd("d", 7, dtValue) 'increment the date by a week
Loop
'dtValue is now equal to a date in the next month, so decrement it by a week to calculate quantity value for the short week
dtValue = DateAdd("d", -7, dtValue)
'now take care of the incomplete week and add a record for the last incomplete week
rstWeek.AddNew
rstWeek!Customer = ![Customer]
rstWeek!MonthNumber = Month(CDate(![DateFld]))
rstWeek!Year = Year(Month(CDate(![DateFld])))
rstWeek!WeekNumber = intCounter
rstWeek!Qty = (!Qty / intDays) * getRemainingDays(dtValue) + (getNextMonthsQty(dtValue) / getNextMonthsDays(dtValue)) * (7 - getRemainingDays(dtValue))
Else
'records already exist - do nothing
rstTest.Close
Set rstTest = Nothing
End If
.MoveNext
Loop
End With
rstMonth.Close
Set rstMonth = Nothing 'free up memory
rstWeek.Close
Set rstWeek = Nothing 'free up memory
End Sub
Public Function daysInMonth(dtDate As Date) As Integer
daysInMonth = Day(DateAdd("d", -1, DateAdd("m", 1, CDate(Month(dtDate) & "/1/" & Year(dtDate)))))
End Function
Public Function getDateOfFirstFullWeek(dtDate As Date) As Date
'Returns date of first full week in the month as partial first week would have been included as part of last week of previous month
Dim dtFirstOfMonth As Date
dtFirstOfMonth = CDate(Month(dtDate) & "/1/" & Year(dtDate))
Do Until Weekday(dtFirstOfMonth) = vbSunday
dtFirstOfMonth = DateAdd("d", 1, dtFirstOfMonth)
Loop
getDateOfFirstFullWeek = dtFirstOfMonth
End Function
Public Function getRemainingDays(dtDate As Date) As Integer
Dim intCount As Integer
Dim dtFirstOfMonth As Date
dtFirstOfMonth = CDate(Month(dtDate) & "/1/" & Year(dtDate))
Do While Month(dtDate) = Month(dtFirstOfMonth)
intCount = intCount + 1
dtDate = DateAdd("d", 1, dtDate)
Loop
getRemainingDays = intCount
End Function
Public Function getNextMonthsQty(dtValue As Date) As Long
' Returns zero if there is no data for the next month
getNextMonthsQty = Nz(DLookup("Qty", "tblMonthData", "WHERE (((tblMonthData.DateFld)=DateAdd('m',1," & dtValue & ")))"), 0)
End Function
Public Function getNextMonthsDays(dtValue As Date) As Integer
'Returns number of days in the next month
getNextMonthsDays = Day(DateAdd("d", -1, DateAdd("m", 2, CDate(Month(dtValue) & "/1/" & Year(dtValue)))))
End Function
