Excel - Data validation formula

Issue

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  

Thanks to rizvisa1 for this tip.