I have a spread sheet that tracks attendance. What I want to do is to alert the user whenever 3 OR MORE CELLS IN SEQUENCE CONTAIN THE SAME DATA. eg. If someone calls in sick, a S is placed in the cell, if this person is sick Mon, Tues, Wed, I would like to alert the user. ( 3 days in sequence with the same data ). If the person is sick on Thur aswell, I want to alert the user again.
Solution
1. Press ALT + F11 to open VBE
2. Press CTRL + R to open Project Explorer
3. Double click on the sheet in which you want this message box
4. Paste the code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vPos As Variant
Dim iCol As Integer
Dim CellValue As Variant
If ((Target.Columns.Count = 1) And (Target.Rows.Count = 1)) Then
If Target = "" Then Exit Sub
End If
vPos = ""
Application.EnableEvents = False
For Each Cell In Target
If UCase(Cell) <> "S" Then GoTo Next_Cell
vPos = ""
iCol = Cell.Column
If iCol >= 3 Then
If ((Cell = Cell.Offset(0, -2)) And (Cell.Offset(0, -1) = Cell)) Then
vPos = -1
End If
End If
If ((vPos = "") And (iCol >= 2) And (iCol < Columns.Count)) Then
If ((Cell = Cell.Offset(0, -1)) And (Cell.Offset(0, 1) = Cell)) Then
vPos = 0
End If
End If
If ((vPos = "") And (iCol < Columns.Count - 1)) Then
If ((Cell = Cell.Offset(0, 1)) And (Cell.Offset(0, 2) = Cell)) Then
vPos = 1
End If
End If
If (vPos <> "") Then
GoTo End_Sub
End If
Next_Cell:
Next
End_Sub:
Application.EnableEvents = True
If (vPos <> "") Then
MsgBox "Three in a row"
End If
End Sub
If you the alerts to be enabled only for weekdays (Monday to Friday).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vPos As Variant
Dim iCol As Integer
Dim CellValue As Variant
Dim iOffsetL2 As Integer
Dim iOffsetL1 As Integer
Dim iOffsetR1 As Integer
Dim iOffset2 As Integer
Dim CellL2 As Variant
Dim CellL1 As Variant
Dim Cell0 As Variant
Dim CellR1 As Variant
Dim CellR2 As Variant
If ((Target.Columns.Count = 1) And (Target.Rows.Count = 1)) Then
If Target = "" Then Exit Sub
End If
vPos = ""
' Exit Sub
On Error GoTo End_Sub
Application.EnableEvents = False
For Each Cell In Target
Cell0 = UCase(Cell.Value)
'If Cell0 <> "S" Then GoTo Next_Cell
vPos = ""
iOffsetL2 = 0
iOffsetL1 = 0
iOffsetR1 = 0
iOffsetR2 = 0
iCol = Cell.Column
If (IsDate(Cells(1, iCol))) Then
CellL2 = "Garbage Value"
CellL1 = "Garbage Value"
CellR1 = "Garbage Value"
CellR2 = "Garbage Value"
Select Case (Weekday(Cells(1, iCol), vbMonday))
Case Is = 1
iOffsetL2 = -2
iOffsetL1 = -2
iOffsetR1 = 0
iOffsetR2 = 0
Case Is = 2
iOffsetL2 = -2
iOffsetL1 = 0
iOffsetR1 = 0
iOffsetR2 = 0
Case Is = 4
iOffsetL2 = 0
iOffsetL1 = 0
iOffsetR1 = 0
iOffsetR2 = 2
Case Is = 5
iOffsetL2 = 0
iOffsetL1 = 0
iOffsetR1 = 2
iOffsetR2 = 2
End Select
End If
On Error Resume Next
CellL2 = Cell.Offset(0, (-2 + iOffsetL2)).Value
CellL1 = Cell.Offset(0, (-1 + iOffsetL1)).Value
CellR1 = Cell.Offset(0, (1 + iOffsetR1)).Value
CellR2 = Cell.Offset(0, (2 + iOffsetR2)).Value
On Error GoTo End_Sub
CellL2 = UCase(CellL2)
CellL1 = UCase(CellL1)
CellR1 = UCase(CellR1)
CellR2 = UCase(CellR2)
If (iCol + iOffsetL2 > 2) Then
' ? ? X
If ((CellL2 = Cell0) And (CellL1 = Cell0)) Then
vPos = -1
GoTo End_Sub
End If
End If
If ((iCol + iOffsetL1 > 0) And ((iCol - iOffsetR1) < Columns.Count)) Then
' ? X ?
If ((CellL1 = Cell0) And (Cell0 = CellR1)) Then
vPos = 0
GoTo End_Sub
End If
End If
If (iCol < Columns.Count - 1) Then
' X ? ?
If ((Cell0 = CellR1) And (Cell0 = CellR2)) Then
vPos = 1
GoTo End_Sub
End If
End If
Next_Cell:
Next
End_Sub:
Application.EnableEvents = True
If (vPos <> "") Then
MsgBox "Three in a row"
End If
End Sub
