Private Sub Worksheet_Change(ByVal Target As Range)
' ********** CODE BLOCK 1 **********
Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim r As Long
Dim c As Long
Set rng = Intersect(Target, Range("E2:H200"))
ActiveSheet.Unprotect
Application.EnableEvents = False
If Not rng Is Nothing Then
' Loop through updated cells in range
For Each cell In rng
' Get row and column number of updated cell
r = cell.Row
c = cell.Column
' Count how many cells have "Y" in current row
Set rng2 = Range("E" & r & ":H" & r)
If Application.WorksheetFunction.CountIf(rng2, "Y") > 1 Then
' Clear entry
cell.ClearContents
' Return message
MsgBox "You can put one Y in cell range E-H " & cell.Address(0, 0), vbOKOnly, "ERROR!"
ElseIf Application.WorksheetFunction.CountIf(rng2, "Y") = 1 Then
' See which column was updated and make appropriate adjustments
If LCase(cell) = "y" Then
Select Case c
' What to do if column E updated to "y"
Case 5
'enter any desired code here
' What to do if column F updated to "y"
Case 6
'enter any desired code here
' What to do if column G updated to "y"
Case 7
'enter any desired code here
' What to do if column H updated to "y"
Case 8
With Cells(r, "B")
.NumberFormat = "dd/mm/yyyy"
.Value = Date
End With
End Select
End If
Else
Cells(r, "B").Value = ""
End If
Next cell
Application.EnableEvents = True
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFormattingCells:=True
End If
' ********** CODE BLOCK 2 **********
Dim rng1 As Range
Dim cell1 As Range
' Check to see if any cells updated in range G2:G200 on "testdata" sheet
Set rng1 = Intersect(Target, Range("G2:G200"))
' Loop through updated cells
If Not rng1 Is Nothing Then
' Unprotect results sheet
Sheets("results").Activate
ActiveSheet.Unprotect
For Each cell1 In rng1
Select Case UCase(cell1)
' Add date stamp to column B on "results" sheet if "Y" added to column G
Case "Y"
Sheets("results").Cells(cell1.Row, "B") = Now()
' Clear date stamp from column B on "results" if column G changed to blank
Case ""
Sheets("results").Cells(cell1.Row, "B").ClearContents
End Select
Next cell1
' Reprotect sheet
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFormattingCells:=True
Sheets("testdata").Activate
End If
' ********** CODE BLOCK 3 **********
Dim rng3 As Range
Dim cell3 As Range
' Check to see if any cells updated in range H2:H200 on "testdata" sheet
Set rng3 = Intersect(Target, Range("H2:H200"))
' Loop through updated cells
If Not rng3 Is Nothing Then
' Unprotect sheet
ActiveSheet.Unprotect
For Each cell3 In rng3
Select Case UCase(cell3)
' Add date stamp to column B if "Y" added to column H
Case "Y"
Cells(cell3.Row, "B") = Now()
' Clear date stamp from column B if column H changed to blank
Case ""
Cells(cell3.Row, "B").ClearContents
End Select
Next cell3
' Reprotect sheet
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFormattingCells:=True
End If
Application.EnableEvents = True
End Sub
