Dim SelfEditing As Boolean
Dim ActivatingForm As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TopEmpRow As Integer
Dim AssociateID As String
Dim ThisValue As String
Dim MRange As String
Dim ThisRow As Integer
Dim i As Integer
Dim LastRow As Integer
On Error Resume Next
If Target.Count > 1 Then
Exit Sub
End If
If Not Intersect(Range("AA1"), Target) Is Nothing Then
ActivatingForm = False
If Trim(Range("AA1").Value) = "" Then
If MsgBox("This Audit MAY take up to 15 minutes AND disable your computer for that period of time" & vbCrLf & vbCrLf & "Do you wish to Continue?", vbYesNo, "Audit Confirmation") = vbNo Then
SelfEditing = True
Range("AA1").Value = "DELETE CELL TO AUDIT ATTENDANCE SHEET"
SelfEditing = False
Exit Sub
End If
ActivatingForm = True
TopEmpRow = 8
Application.Cursor = xlWait
Application.DisplayStatusBar = True
Do Until UCase(Trim(Range("D" & TopEmpRow).Value)) = "GRAND TOTAL"
AssociateID = Trim(Range("D" & TopEmpRow).Value)
' here we're searching for the LAST ROW of each associate's record
Do Until Not IsNumeric(AssociateID)
AssociateID = Trim(Range("D" & TopEmpRow).Value)
TopEmpRow = TopEmpRow + 1
Loop
' now go up TWO rows to the LAST ROW
TopEmpRow = TopEmpRow - 2
MRange = "M" & TopEmpRow
Application.StatusBar = "Auditing Associate ID " & Trim(Range("D" & TopEmpRow).Value) & ", Row # " & TopEmpRow
' grab whatever value is in the "M" column
ThisValue = Trim(Range(MRange).Value)
SelfEditing = True
' place a new character in the "M column. This triggers code below
Range(MRange).Value = "*"
' set the SelfEditing flag to true so that NO CODE BELOW executes
SelfEditing = False
Range(MRange).Value = ThisValue
' set the SelfEditing flag to false to re-enable code execution
' increment the row counter TWO places to go to the NEXT associate's record
TopEmpRow = TopEmpRow + 2
Loop
Application.DisplayStatusBar = False
Application.Cursor = xlDefault
SelfEditing = True
Range("AA1").Value = "DELETE CELL TO AUDIT ATTENDANCE SHEET"
SelfEditing = False
ActivatingForm = False
End If
Else
If Not SelfEditing Then
If Not Intersect(Range("M" & Target.Row), Target) Is Nothing Then
If Not ActivatingForm Then
Application.Cursor = xlWait
End If
TopEmpRow = Target.Row
Do Until Not IsNumeric(Trim(Range("D" & TopEmpRow)))
TopEmpRow = TopEmpRow - 1
Loop
TopEmpRow = TopEmpRow + 1
Call ProcessRows(TopEmpRow)
If Not ActivatingForm Then
Application.Cursor = xlDefault
End If
End If
End If
End If
End Sub
Private Sub ProcessRows(WhichRow As Integer)
Dim SelectedStartDate As Date
Dim SelectedEndDate As Date
Dim EndDateFound As Boolean
Dim SelectedRow As Integer
Dim DateLoc As Integer
Dim DiffDays As Integer
Dim AddDays As Integer
Dim RowNum As Integer
Dim SelectedAssociateID As String
Dim ParsedData As String
Dim KRange As String
Dim MRange As String
Dim FRange As String
Dim HFormula As String
Dim IFormula As String
Dim NFormula As String
Dim rsOver5Days As ADODB.Recordset
Dim rs As ADODB.Recordset
On Error Resume Next
SelectedRow = WhichRow
SelectedAssociateID = Trim(Range("D" & SelectedRow).Value)
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Fields.Append "RowNum", adInteger, 3, adFldUpdatable
rs.Fields.Append "StartDate", adDate, , adFldUpdatable
rs.Fields.Append "EditField", adInteger, , adFldUpdatable
rs.Open
Set rsOver5Days = New ADODB.Recordset
rsOver5Days.CursorLocation = adUseClient
rsOver5Days.Fields.Append "RowNum", adInteger, 2, adFldUpdatable
rsOver5Days.Fields.Append "StartDate", adDate, , adFldUpdatable
rsOver5Days.Fields.Append "EndDate", adDate, , adFldMayBeNull
rsOver5Days.Fields.Append "DiffDays", adInteger, , adFldUpdatable
rsOver5Days.Open
Do Until Not IsNumeric(SelectedAssociateID)
KRange = "K" & SelectedRow
MRange = "M" & SelectedRow
FRange = "F" & SelectedRow
EndDateFound = False
SelectedStartDate = CDate(Trim(Range(FRange).Value))
If IsDate(Trim(Range(MRange).Value)) Then ' if there is a date in the "M" column
SelectedEndDate = CDate(Trim(Range(MRange).Value)) ' Convert the string to a date
EndDateFound = True
Else
DateLoc = InStr(1, Trim(Range(KRange).Value), "/") ' is there a slash ("/") in the "K" column?
If DateLoc = 0 Then ' there ISN'T a slash in the "K" column
DateLoc = InStr(1, Trim(Range(KRange).Value), "-") ' is there a hyphen ("-") in the "K" column?
If DateLoc > 0 Then ' Thre IS a hypen in the "K" column
ParsedData = ParseCommentsForDate(DateLoc, SelectedRow, "-")
If IsDate(ParsedData) Then
SelectedEndDate = CDate(ParsedData)
EndDateFound = True
End If
End If
Else ' There IS a slash, parse the data to see if it's a Date !
ParsedData = ParseCommentsForDate(DateLoc, SelectedRow, "/")
If IsDate(ParsedData) Then ' it IS a Date
SelectedEndDate = CDate(ParsedData)
EndDateFound = True
End If
End If
End If
rs.AddNew
rs!RowNum = SelectedRow
rs!StartDate = SelectedStartDate
If Trim(Range("G" & SelectedRow).Value) > 0 Then
rs!EditField = 1
Else
rs!EditField = 0
End If
rs.Update
If EndDateFound Then
If Not ActivatingForm Then
If SelectedEndDate < SelectedStartDate Then
Call MsgBox("The Thru Date CANNOT BE BEFORE the Date Missed", vbOKOnly, "Invalid Entry")
SelfEditing = True
Range("M" & SelectedRow).Value = ""
Range("M" & SelectedRow).Select
SelfEditing = False
Exit Sub
End If
End If
DiffDays = DateDiff("d", SelectedStartDate, SelectedEndDate) + 1
If DiffDays > 5 Then
rsOver5Days.AddNew
rsOver5Days!RowNum = SelectedRow
rsOver5Days!StartDate = SelectedStartDate
rsOver5Days!EndDate = SelectedEndDate
rsOver5Days!DiffDays = DiffDays
rsOver5Days.Update
End If
End If
SelectedRow = SelectedRow + 1
SelectedAssociateID = Trim(Range("D" & SelectedRow).Value)
Loop
If rs.RecordCount > 0 Then
rs.MoveFirst
rs.Sort = "RowNum"
DoEvents
rsOver5Days.Sort = "RowNum"
DoEvents
Do Until rs.RecordCount = 0
RowNum = Trim(rs!RowNum) ' trim out of habit
If Trim(rs!EditField) = 1 Then
rsOver5Days.MoveFirst
AddDays = 365
Do Until rsOver5Days.EOF
' we are only concerned with the "OVER 5 DAY" record that occurred AFTER the "Date Missed"
' AND where the "OVER 5 DAY" record's "Start Date" <= (365 + number-of-over-5-day-periods)
' -- which is a moving target, so-to-speak
If (CDate(Trim(rsOver5Days!StartDate)) > CDate(Trim(rs!StartDate)) And CDate(Trim(rsOver5Days!StartDate)) <= DateAdd("d", AddDays, CDate(Trim(rs!StartDate)))) Then
AddDays = AddDays + Trim(rsOver5Days!DiffDays)
End If
rsOver5Days.MoveNext
Loop
' here we build the formulas that will appear in each of the cells.
HFormula = "=IF($E$2-F" & RowNum & "<" & AddDays & ",G" & RowNum & ",0)"
IFormula = "=IF(H" & RowNum & "=0,"""",IF(H" & RowNum & "<=2,0.25,IF(H" & RowNum & "<=4,0.5,IF(H" & RowNum & "<=6,0.75,IF(H" & RowNum & "<=7.99,1,IF(H" & RowNum & ">=8,H" & RowNum & "/8*1,""""))))))"
NFormula = "=F" & RowNum & "+" & AddDays
SelfEditing = True
Range("H" & RowNum).Formula = HFormula
Range("I" & RowNum).Formula = IFormula
Range("N" & RowNum).Formula = NFormula
SelfEditing = False
Else
HFormula = "=IF($E$2-F" & RowNum & "<365,G" & RowNum & ",0)"
IFormula = "=IF(H" & RowNum & "=0,"""",IF(H" & RowNum & "<=2,0.25,IF(H" & RowNum & "<=4,0.5,IF(H" & RowNum & "<=6,0.75,IF(H" & RowNum & "<=7.99,1,IF(H" & RowNum & ">=8,H" & RowNum & "/8*1,""""))))))"
NFormula = "=F" & RowNum & "+365"
SelfEditing = True
Range("H" & RowNum).Formula = HFormula
Range("I" & RowNum).Formula = IFormula
Range("N" & RowNum).Formula = NFormula
SelfEditing = False
End If
rs.Delete adAffectCurrent
DoEvents
If rs.RecordCount > 0 Then
rs.MoveNext
End If
Loop
End If
rsOver5Days.Close
Set rsOver5Days = Nothing
rs.Close
Set rs = Nothing
End Sub
Private Function ParseCommentsForDate(DateLoc As Integer, SelectedRow As Integer, Delim As String) As String
Dim ThruDate As String
Dim AllComments As String
Dim Count As Integer
Dim SearchString As String
On Error Resume Next
DateLoc = DateLoc - 2 ' go back two characters from the position of the "/" in the comments
If DateLoc <= 0 Then
ParseCommentsForDate = ""
Exit Function
End If
SearchString = "/" ' set a default value for searchstring so that it ENTERS the Do Loop
ThruDate = ""
Count = 0
Do Until Trim(SearchString) = "" Or Count = 10
SearchString = Mid(Trim(Range("K" & SelectedRow)), DateLoc, 1)
If SearchString = Delim Or IsNumeric(SearchString) Then
ThruDate = ThruDate & SearchString
ElseIf Count = 0 Then
SearchString = "/"
End If
Count = Count + 1
DateLoc = DateLoc + 1
Loop
If IsDate(Trim(ThruDate)) Then
' move the date FROM the 'Reason' column and into the 'Thru Date' column
AllComments = Range("K" & SelectedRow)
AllComments = Replace(AllComments, Trim(ThruDate), "")
SelfEditing = True
Range("K" & SelectedRow).Value = AllComments
Range("M" & SelectedRow).Value = Trim(ThruDate)
SelfEditing = False
End If
ParseCommentsForDate = Trim(ThruDate)
End Function