Auto Delete Number Constant After Certain Time Frame

[ssanfu]

I added a table for Supervisors and made a couple of other changes...



(Still not liking the object names - special characters and LOTS of spaces in names - both bad ideas.)

How about this?

[Mearntain]

Everything seems to be working great. Thanks again for all the help. I need to work on learning some VBA myself. I know a very little, but not much at all.

[ssanfu]

Great!!

So ready to mark this solved??

[Mearntain]

Yes, Im looking but dont see where to mark it as solved. I thought that was something moderators did?

[Homegrownandy]

Thread tools (second green bar on the screen). Mark as solved.

[Homegrownandy]

I've just marked it as solved. I don't know why I'm trusted with such responsibility.

[ssanfu]

I don't know why I'm trusted with such responsibility.

Only you know if the question/problem has been solved to your satisfaction.
I am confident you can handle the responsibility!

(BTW, You can also remove the solved indication.... )

[Homegrownandy]

Only you know if the question/problem has been solved to your satisfaction.

This isnt my thread though! I could go and mark them all as solved it seems.

[Homegrownandy]

Its just this thread. I've posted on another thread and i cant click "solved" on it.. strange

[ssanfu]

Anyone that has posted in a thread can mark it solved/unsolved.
Usually it is the OP that marks the thread solved......... but twice I have marked a thread solved (by request of the OP).

[Mearntain]

I know how to mark them solved now and will do that in the future. I now have marked the thread as UNSOLVED as I found an issue in the code that I am unsure of how to correct.

When the code searches the table to see if it has been 90 days since the last set of points, it will give -3 points regardless of the total number of points. The max number of total points anyone can ever have is -3 points.

For instance, Bob currently has a total of 2 points and it has been 90 days since the last entry. The code currently would add a record of -3 points which would be correct in this situation, leaving him at a final total points of -1 points.

However, if Bob currently has a total of -1 points and it has been an additional 90 days, a record of -3 points would now give him a total of -4 points which is not OK since -3 is the lowest you can go. In this case, Bob should only have a record of -2 points added after 90 days. If he currently had a total of -2 points, a new record of only -1 points should be added at 90 days. And if he is already at a total of -3 points, a record of 0 points should be added.

Hopefully that makes sense and someone can help with the syntax of adding that IF statement to the code to correct the issue. Thanks in advance.

Option Compare DatabaseOption Explicit


Public Sub UpdatePointsDeductions()
    Dim d As DAO.Database
    Dim r As DAO.Recordset
    Dim sSQL As String
    Dim dteCurrentDate As Date
    Dim dteMaxEmpDate As Date


    Set d = CurrentDb
    dteCurrentDate = Date


    sSQL = "SELECT [Attendance Points].[Employee Name], [Attendance Points].[Supervisor Name],Sum([Attendance Points].[Points Assessed]) AS totalPts,"
    sSQL = sSQL & " Max([Attendance Points].[Day of Absence/Tardiness]) AS MaxDate"
    sSQL = sSQL & " FROM [Attendance Points]"
    sSQL = sSQL & " GROUP BY [Attendance Points].[Employee Name], [Attendance Points].[Supervisor Name]"
    sSQL = sSQL & " HAVING Sum([Attendance Points].[Points Assessed]) > -3"
    sSQL = sSQL & " ORDER BY [Attendance Points].[Employee Name];"
    '    Debug.Print sSQL
    Set r = d.OpenRecordset(sSQL)


    If r.BOF And r.EOF Then


    Else
        With r
            .MoveLast
            .MoveFirst
            Do While Not .EOF
                dteMaxEmpDate = DateAdd("d", 90, !MaxDate)
                If (!totalpts > -3) And (dteMaxEmpDate <= dteCurrentDate) Then
                    'add -3 points
                    sSQL = "INSERT INTO [Attendance Points] ( [Employee Name], [Supervisor Name], [Day of Absence/Tardiness], [Points Assessed], Comments )"
                    sSQL = sSQL & " VALUES ('" & ![Employee Name] & "', '" & ![Supervisor Name] & "', #" & dteMaxEmpDate & "#,  -3, '3 points deducted')"
                    '    Debug.Print sSQL
                    d.Execute sSQL, dbFailOnError
                End If
                .MoveNext
            Loop
        End With
    End If


    On Error Resume Next
    r.Close
    Set r = Nothing
    Set d = Nothing


End Sub

[ssanfu]

Try these changes...also added a function to calc the points to add.

Public Sub UpdatePointsDeductions()
    Dim d As DAO.Database
    Dim r As DAO.Recordset
    Dim sSQL As String
    Dim dteCurrentDate As Date
    Dim dteMaxEmpDate As Date
    Dim iPoints As Integer

    Set d = CurrentDb
    dteCurrentDate = Date

    sSQL = "SELECT [Attendance Points].[Employee Name], [Attendance Points].[Supervisor Name],Sum([Attendance Points].[Points Assessed]) AS totalPts,"
    sSQL = sSQL & " Max([Attendance Points].[Day of Absence/Tardiness]) AS MaxDate"
    sSQL = sSQL & " FROM [Attendance Points]"
    sSQL = sSQL & " GROUP BY [Attendance Points].[Employee Name], [Attendance Points].[Supervisor Name]"
    sSQL = sSQL & " HAVING Sum([Attendance Points].[Points Assessed]) > -3"
    sSQL = sSQL & " ORDER BY [Attendance Points].[Employee Name];"
    '    Debug.Print sSQL
    Set r = d.OpenRecordset(sSQL)

    If r.BOF And r.EOF Then

    Else
        With r
            .MoveLast
            .MoveFirst
            Do While Not .EOF
                dteMaxEmpDate = DateAdd("d", 90, !MaxDate)
                If (!totalpts > -3) And (dteMaxEmpDate <= dteCurrentDate) Then
                    'add -3 points
                    iPoints = CalcPointsToAdd(!totalpts)
                    sSQL = "INSERT INTO [Attendance Points] ( [Employee Name], [Supervisor Name], [Day of Absence/Tardiness], [Points Assessed], Comments )"
                    sSQL = sSQL & " VALUES ('" & ![Employee Name] & "', '" & ![Supervisor Name] & "', #" & dteMaxEmpDate & "#, " & iPoints & ", 'Good Job! 3 points deducted.')"
                    '    Debug.Print sSQL
                    d.Execute sSQL, dbFailOnError
                End If
                .MoveNext
            Loop
        End With
    End If

    On Error Resume Next
    r.Close
    Set r = Nothing
    Set d = Nothing

End Sub


'-------new function--------
Private Function CalcPointsToAdd(iCurPoints As Integer) As Integer
    'calculate points to add
    Dim iPointsToAdd As Integer

    iPointsToAdd = -3 - iCurPoints
    
    If iPointsToAdd < -3 Then
        iPointsToAdd = -3
    End If
    CalcPointsToAdd = iPointsToAdd
End Function

[Mearntain]

Perfect. That looks like it did it. Thanks alot

[ssanfu]

Whew!! Success at last.

Good luck on your project.. this was fun. Made me think....