How to find a data anomaly in a row

[Ed Harris]

Hello,
I am trying to highlight anomalous values in my data by colouring the cell. I was kindly given a macro by offthelip last year which was really usefull but now I have much more data and the problem is that the macro highlights the cells either side of the anomaly as well. I havent been able to improve the macro myself. Is there a better mathematical expression for "mecells" that will select just the anomalous value to highlight? here is the macro and data example.

Sub testyellow()
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 30))
For I = 3 To lastrow
For j = 2 To 25
mecells = (inarr(I, j - 1) + inarr(I, j + 1)) / 2
Delta = Abs(mecells - inarr(I, j))
If Delta >= 0.004 Then
With Range(Cells(I, j), Cells(I, j)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 255, 0) 'yellow
.TintAndShade = 0
.PatternTintAndShade = 0
End With

End If
Next j
Next I
End Sub

Beam2 2022.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y
1	73.4157	73.41557	73.41576	73.41544	73.41579	73.41525	73.41482	73.41538	73.41531	73.41539	73.41525	73.41563	73.41502	73.41547	73.41492	73.41541	73.41563	73.41584	73.4152	73.41562	73.41531	73.41537	73.41511	73.41494	73.41538
2	73.41315	73.41335	73.41324	73.41319	73.41325	73.41312	73.41306	73.41303	73.41318	73.41303	73.41315	73.41302	73.41314	73.41317	73.41311	73.41319	73.41318	73.41311	73.41311	73.41316	73.41325	73.41307	73.41313	73.41328	73.41306
3	73.41209	73.42255	73.41192	73.41206	73.41135	73.41229	73.47526	73.41032	73.41225	73.41213	73.36955	73.41216	73.41208	73.35071	73.4123	73.412	73.41247	73.41185	73.412	73.41207	73.41248	73.41222	73.41206	73.36831	73.41209
4	73.41586	73.4155	73.41531	73.41535	73.41516	73.41534	73.41612	73.41525	73.41521	73.41589	73.41547	73.41526	73.41534	73.41495	73.41544	73.41544	73.41602	73.41518	73.41459	73.41457	73.41458	73.41534	73.4148	73.4154	73.41493
5	73.41544	73.41534	73.4154	73.41518	73.41522	73.41566	73.4155	73.41586	73.41544	73.41528	73.41508	73.41556	73.41551	73.4156	73.41539	73.41488	73.4156	73.41525	73.41531	73.41508	73.41531	73.41523	73.41573	73.41567	73.41564
6
7
8	-0.01045	0.010627	-0.00015	0.000718	-0.00095	-0.06297	0.062966	-0.06494	0.001938	-0.00012	-0.04258	0.04261	-8.4E-05	-0.06137	0.061592	-0.0003	0.000473	-0.00062	0.000145	7.6E-05	0.000412	-0.00027	-0.00015	-0.04376	0.043777
Sheet5

Cell Formulas
Range	Formula
A8:F8	A8	=A3-B3
G8:Y8	G8	=G3-F3

 

[6StringJazzer]

Giving us code that does the wrong thing doesn't help to know what is the right thing. Can you please define how to identify the anomaly? I suspect that the code conforms exactly to your definition, but the problem is with your definition. This code colors every cell that has a difference of more than 0.004 from the average of the cells to either side of it. By that definition, all the yellow cells are correctly identified as anomalies.

Also this looks like something that could be done much more simply with conditional formatting, without any VBA code.

$scratch.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y
1	73.4157	73.415573	73.41576	73.41544	73.41579	73.41525	73.41482	73.41538	73.41531	73.41539	73.41525	73.41563	73.41502	73.41547	73.41492	73.41541	73.41563	73.41584	73.4152	73.41562	73.41531	73.41537	73.41511	73.41494	73.41538
2	73.41315	73.413345	73.41324	73.41319	73.41325	73.41312	73.41306	73.41303	73.41318	73.41303	73.41315	73.41302	73.41314	73.41317	73.41311	73.41319	73.41318	73.41311	73.41311	73.41316	73.41325	73.41307	73.41313	73.41328	73.41306
3	73.41209	73.422546	73.41192	73.41206	73.41135	73.41229	73.47526	73.41032	73.41225	73.41213	73.36955	73.41216	73.41208	73.35071	73.4123	73.412	73.41247	73.41185	73.412	73.41207	73.41248	73.41222	73.41206	73.36831	73.41209
4	73.41586	73.415504	73.41531	73.41535	73.41516	73.41534	73.41612	73.41525	73.41521	73.41589	73.41547	73.41526	73.41534	73.41495	73.41544	73.41544	73.41602	73.41518	73.41459	73.41457	73.41458	73.41534	73.4148	73.4154	73.41493
5	73.41544	73.415344	73.4154	73.41518	73.41522	73.41566	73.4155	73.41586	73.41544	73.41528	73.41508	73.41556	73.41551	73.4156	73.41539	73.41488	73.4156	73.41525	73.41531	73.41508	73.41531	73.41523	73.41573	73.41567	73.41564
Anomaly

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
B1:X8	Expression	=ABS(B1-AVERAGE(A1,C1))>0.004	text	NO

 

[Ed Harris]

Yes thanks for you comments. Only the cells I have put a border around should be yellow. For example F3 and H3 are much the same as I3 at 73.412, 73.410 and 73.413 respectively whilst G3 is 73.475 this one is an anomaly because its is 0.063 bigger. The graph below shows the anomalies which can be positive or negative.

 

[6StringJazzer]

I intuitively understand what you mean but you haven't given a mathematical definition of what an anomaly is.

Based on your qualitative description I would define an anomaly as a data point that more than 0.004 from both of it's neighboring points. I would still use conditional formatting an scrap the code.

If you would rather keep using VBA I can fix the code too.

$scratch.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y
1	73.4157	73.415573	73.41576	73.41544	73.41579	73.41525	73.41482	73.41538	73.41531	73.41539	73.41525	73.41563	73.41502	73.41547	73.41492	73.41541	73.41563	73.41584	73.4152	73.41562	73.41531	73.41537	73.41511	73.41494	73.41538
2	73.41315	73.413345	73.41324	73.41319	73.41325	73.41312	73.41306	73.41303	73.41318	73.41303	73.41315	73.41302	73.41314	73.41317	73.41311	73.41319	73.41318	73.41311	73.41311	73.41316	73.41325	73.41307	73.41313	73.41328	73.41306
3	73.41209	73.422546	73.41192	73.41206	73.41135	73.41229	73.47526	73.41032	73.41225	73.41213	73.36955	73.41216	73.41208	73.35071	73.4123	73.412	73.41247	73.41185	73.412	73.41207	73.41248	73.41222	73.41206	73.36831	73.41209
4	73.41586	73.415504	73.41531	73.41535	73.41516	73.41534	73.41612	73.41525	73.41521	73.41589	73.41547	73.41526	73.41534	73.41495	73.41544	73.41544	73.41602	73.41518	73.41459	73.41457	73.41458	73.41534	73.4148	73.4154	73.41493
5	73.41544	73.415344	73.4154	73.41518	73.41522	73.41566	73.4155	73.41586	73.41544	73.41528	73.41508	73.41556	73.41551	73.4156	73.41539	73.41488	73.4156	73.41525	73.41531	73.41508	73.41531	73.41523	73.41573	73.41567	73.41564
Anomaly

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A1:Y8	Expression	=AND(NOT(ISBLANK(OFFSET(A1,0,1))),ABS(A1-OFFSET(A1,0,1))>0.004,ABS(A1-OFFSET(A1,0,-1))>0.004)	text	NO

 

[6StringJazzer]

Here's the code. I strongly suggest using code tags when you post code to preserve the spacing and format.

Sub testyellow()

   Dim i As Long, j As Long
   Dim LastRow As Long
   Dim InArr As Variant
   Dim DeltaLeft As Double
   Dim DeltaRight As Double
   
   Const Tolerance = 0.004
   
   LastRow = Cells(Rows.Count, "A").End(xlUp).Row
   InArr = Range(Cells(1, 1), Cells(LastRow, 30))
   
   
   For i = 3 To LastRow
      For j = 2 To 25
      
         DeltaLeft = Abs(InArr(i, j) - InArr(i, j - 1))
         
         If Not IsEmpty(InArr(i, j + 1)) Then
            DeltaRight = Abs(InArr(i, j) - InArr(i, j + 1))
         Else
            DeltaRight = 0
         End If
         
         If DeltaRight >= Tolerance And DeltaLeft >= Tolerance Then
         With Range(Cells(i, j), Cells(i, j)).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = RGB(255, 255, 0) 'yellow
            .TintAndShade = 0
            .PatternTintAndShade = 0
         End With
         
         End If
      Next j
   Next i

End Sub

 

[Ed Harris]

Jeff, It works perfectly, I cant thank you enough for doing this for me. I will now go and apply it to my outstanding four months of data (not all at once ) though over one million cells.
Ed

 

[Ed Harris]

Here's the code. I strongly suggest using code tags when you post code to preserve the spacing and format.

Sub testyellow()

   Dim i As Long, j As Long
   Dim LastRow As Long
   Dim InArr As Variant
   Dim DeltaLeft As Double
   Dim DeltaRight As Double
  
   Const Tolerance = 0.004
  
   LastRow = Cells(Rows.Count, "A").End(xlUp).Row
   InArr = Range(Cells(1, 1), Cells(LastRow, 30))
  
  
   For i = 3 To LastRow
      For j = 2 To 25
     
         DeltaLeft = Abs(InArr(i, j) - InArr(i, j - 1))
        
         If Not IsEmpty(InArr(i, j + 1)) Then
            DeltaRight = Abs(InArr(i, j) - InArr(i, j + 1))
         Else
            DeltaRight = 0
         End If
        
         If DeltaRight >= Tolerance And DeltaLeft >= Tolerance Then
         With Range(Cells(i, j), Cells(i, j)).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = RGB(255, 255, 0) 'yellow
            .TintAndShade = 0
            .PatternTintAndShade = 0
         End With
        
         End If
      Next j
   Next i

End Sub

Hi Jeff, this code you made has been working perfectly but lately I have tried to adapt it again to another range of data Columns 1440 to 2880 but it says the inarr variable is "subscript out of range". I have tried adjusting the ranges but cannot find what's wrong. Any ideas?

 

[6StringJazzer]

Can you show the current version of the code that shows what you changed for this adaptation? Not sure what you tried to do in your post but the two code sections are blank.

 

[Ed Harris]

[CODE=vba]Sub b1testyellowHalfHr() ' searches for cells that are higher or lower than their row neighbours and colours them yellow
' for columns 1440 to 2880. REMOVE TEXT FIRST

   Dim i As Long, j As Long
   Dim LastRow As Long
   Dim InArr As Variant
   Dim DeltaLeft As Variant
   Dim DeltaRight As Double
   
   Const Tolerance = 0.004
   
   LastRow = Cells(Rows.Count, "A").End(xlUp).Row
   InArr = Range(Cells(1, 1440), Cells(LastRow, 2880))
   
   
   For i = 3 To LastRow
      For j = 1440 To 2880
      
         DeltaLeft = Abs(InArr(i, j) - InArr(i, j - 1))
         
         If Not IsEmpty(InArr(i, j + 1)) Then
            DeltaRight = Abs(InArr(i, j) - InArr(i, j + 1))
         Else
            DeltaRight = 0
         End If
         
         If DeltaRight >= Tolerance And DeltaLeft >= Tolerance Then
         With Range(Cells(i, j), Cells(i, j)).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = RGB(255, 255, 0) 'yellow
            .TintAndShade = 0
            .PatternTintAndShade = 0
         End With
         
         End If
      Next j
   Next i

End Sub

[/CODE]
Either side of the data in this case are ones or dates. For other data sets I set the "For J" to one cell inside the data array and that made it work but it still found anomalys at the edge - which I dont understand.

 

[6StringJazzer]

InArr = Range(Cells(1, 1440), Cells(LastRow, 2880))

This will assign InArr to have cell values from rows 1440 to 2880. This is 1441 rows so InArr will have rows 1 - 1441. However, you are trying to index it from 1440 to 2880

     For j = 1440 To 2880

As soon as j reaches 1442 it will raise an error.

You cannot use the same j to reference cell rows and also rows in the array InArr as in the two lines below

            DeltaRight = Abs(InArr(i, j) - InArr(i, j + 1))

         With Range(Cells(i, j), Cells(i, j)).Interior

If you want j to refer to the row numbers of cells, you will have to use j - 1439 to index the array.