First I had two tables in my example:
tbl_PersonFunction
FP_ID (autonumber PK)
Person_ID (number, assuming FK to an employee table or the like)
Function_ID (number, assuming FK to a function table)
Function_Date (the date the employee was on that function)
NOTE: I assumed that an employee could not be assigned to the different functions on the same day
tbl_Cons
Cons_ID (autonumber PK)
Person_ID (number, FK to emoployee table)
Start_Date (date, entered by user)
End_Date (date, figured by calculation)
Function_ID (number, FK to function table)
Cons_Days (maximum consecutive days)
Code:
Dim dStartDate As Date
Dim iProjDays As Integer
Dim dEndDate As Date
Dim db As Database
Dim sSQL As String
Dim rst_People As Recordset
Dim iPersonID As Long
Dim rst_Functions As Recordset
Dim dFunDate As Date
Dim dFunDatePrev As Date
Dim iFun As Long
Dim iFunSearch As Long
Dim iCons As Integer
Dim iConsMax As Integer
dStartDate = InputBox("Enter the Starting Date", "Enter the Starting Date of the Reporting Period", #1/1/2013#)
iProjDays = InputBox("Report through how many days?", "Enter the Number of Days following the start date", 7)
dEndDate = DateAdd("d", iProjDays, dStartDate)
Set db = CurrentDb
sSQL = "SELECT Person_ID FROM tbl_PersonFunction WHERE Function_Date Between #" & dStartDate & "# AND #" & dEndDate & "# GROUP BY Person_ID"
Set rst_People = db.OpenRecordset(sSQL)
If rst_People.RecordCount <> 0 Then
db.Execute ("DELETE * FROM tbl_Cons")
Do While rst_People.EOF <> True
iPersonID = rst_People.Fields("Person_ID")
'Debug.Print iPersonID
sSQL = "SELECT * FROM tbl_PersonFunction WHERE Person_ID = " & iPersonID & " AND Function_Date Between #" & dStartDate & "# AND #" & dEndDate & "# ORDER BY Function_Date DESC"
Set rst_Functions = db.OpenRecordset(sSQL)
rst_Functions.MoveFirst
iFunSearch = rst_Functions.Fields("Function_ID") 'sets the function ID we're looking to count consecutive days for
dFunDatePrev = rst_Functions.Fields("Function_Date") 'initializes the date to start counting
iCons = 1 'initializes the consecutive day count
iConsMax = 1
Do While rst_Functions.EOF <> True 'cycles through function records from the most recent to the least recent over the defined period
dFunDate = rst_Functions.Fields("Function_Date")
iFun = rst_Functions.Fields("Function_ID")
If iFun = iFunSearch Then 'if the function date matches the function of the most recent day, keep going
If dFunDate = DateAdd("d", -1, dFunDatePrev) Then 'if the date of the current record is one day prior to the last record add 1 to the consecutive count
iCons = iCons + 1 'increments the consecutive days by 1 if it's a consecutive day
If iCons > iConsMax Then
iConsMax = iCons 'if the current consecutive days is greater than the currrent maximum consecutive days make the maximum consecutive days = current consecutive days
End If
Else
iCons = 1 'if the date of the current record is NOT one day prior the last record, reset the current consecutive days count to 1
End If
dFunDatePrev = dFunDate
Else 'if the function date DOES NOT match the function of the most recent day, move to the last record to exit the function loop
rst_Functions.MoveLast
End If
rst_Functions.MoveNext
Loop
rst_Functions.Close
sSQL = "INSERT INTO tbl_Cons ("
sSQL = sSQL & "Person_ID, "
sSQL = sSQL & "Start_Date, "
sSQL = sSQL & "End_Date, "
sSQL = sSQL & "Function_ID, "
sSQL = sSQL & "Cons_Days"
sSQL = sSQL & ") VALUES ("
sSQL = sSQL & iPersonID & ", "
sSQL = sSQL & "#" & dStartDate & "#, "
sSQL = sSQL & "#" & dEndDate & "#, "
sSQL = sSQL & iFunSearch & ", "
sSQL = sSQL & iConsMax
sSQL = sSQL & ")"
db.Execute (sSQL)
rst_People.MoveNext
Loop
rst_People.Close
Else
MsgBox "no records in the range specified", vbOKOnly, "error: no records in range"
End If
Set db = Nothing
Count values that occur consecutively
Windows 7 64bit 
Access 2010 32bit
Reply With Quote
