Sub CheckMyData()
Dim CellEntry As Range, rg As Range
Dim addr As Variant
With Sheet1
For Each addr In Array("A2", "F2", "K2", "P2", "Y2", "AD2")
Set rg = .Range(CStr(addr))
Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp))
For Each CellEntry In rg.Cells
WorksheetChange CellEntry
Next
Next
End With
Application.OnTime EarliestTime:=Now + TimeValue("00:00:10"), Procedure:="CheckMyData"
End Sub
Sub WorksheetChange(ByVal Target As Range)
Dim rngValue2 As Range, rngGreaterThan As Range, rngLessThan As Range, rngLastAction As Range, rngTimeStamp As Range
Select Case Target.Column
Case Is <= 17
Set rngTimeStamp = Sheet1.Cells(Target.Row, 21 + Int(Target.Column / 5))
Case 25, 26
Set rngTimeStamp = Sheet1.Cells(Target.Row, 35)
Case 30, 31
Set rngTimeStamp = Sheet1.Cells(Target.Row, 36)
End Select
Select Case Target.Column
Case 1, 6, 11, 16, 25, 30
Set rngValue2 = Sheet1.Cells(Target.Row, Target.Column + 1)
Set rngGreaterThan = Sheet1.Cells(Target.Row, Target.Column + 2)
Set rngLessThan = Sheet1.Cells(Target.Row, Target.Column + 3)
Set rngLastAction = Sheet1.Cells(Target.Row, Target.Column + 4)
If Target.Value > rngValue2.Value Then
If rngLastAction <> ">" Then
rngGreaterThan = rngGreaterThan + 1
If Target.Column <> 30 Then rngTimeStamp.Value = Now()
rngLastAction = ">"
End If
ElseIf Target.Value < rngValue2.Value Then
If rngLastAction <> "<" Then
rngLessThan = rngLessThan + 1
If Target.Column <> 25 Then rngTimeStamp.Value = Now()
rngLastAction = "<"
End If
' Else Values are Equal- Do Nothing
' If you want equal values to do something, change the one of the above
' formulas from > to >= or < to <=
End If
End Select
Set rngValue2 = Nothing
Set rngGreaterThan = Nothing
Set rngLessThan = Nothing
Set rngLastAction = Nothing
Set rngTimeStamp = Nothing
End Sub
|