conditional format based on column statistics and loop over columns

[haley]

Hello all,
I would like to have a macro to highlight outliers for each column. The outliers are the values which is not missing , but are out of limits.

The quartile ranges IQR is(use column D as example):
IQR=Q3-Q1=QUARTILE(D244,3)-QUARTILE(D244,1)
upper limit is Q3+IQR
lower limit is Q1+IQR



Here is the macro I recorded for using one test data(one column)

'Sub findoutlier()
''
'' findoutlier Macro
''
''
Range("A1:A43").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND($A1 <> ""."", OR($A1<(QUARTILE(A1:A43, 1)-1.5*(QUARTILE(A1:A43, 3)-QUARTILE(A1:A43, 1))), $A1>(QUARTILE(A1:A43, 1)+1.5*(QUARTILE(A1:A43, 3)-QUARTILE(A1:A43, 1)))))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub


I want to loop over 30 columns, and I added loops, but it does not work

Sub findoutlier()
'
' findoutlier Macro
'
'
Dim i As Long
Dim j As Long
Sheets("Sheet1").Select
For i = 1 To 30
For j = 1 To 44
' Range(Cells(2, i + 3), Cells(44, i + 3)).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND(cells(j, i+3) <> ""."", OR (cells(j, i+3)<(QUARTILE(range(cells(2, i+3), cells(44, i+3)), 1)-1.5*(QUARTILE(range(cells(2, i+3), cells(44, i+3)), 3)-QUARTILE(range(cells(2, i+3), cells(44, i+3)), 1))), (cells(j,i+3)>(QUARTILE(range(cells(2, i+3), cells(44, i+3)), 1)+1.5*(QUARTILE(range(cells(2, i+3), cells(44, i+3)), 3)-QUARTILE(range(cells(2, i+3), cells(44, i+3)), 1)))))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False

Next j
Next i

End Sub

I am not sure if the error is cause by "(QUARTILE(range(cells(". Some similar test takes a long time to loop through all cells and I also would like suggestion on how to make this more efficient.

Any help would be much appreciated.

Haley

 

[Ben McClave]

Haley,

I modified your original code to do this for you. I have not been able to test it yet with actual data, though.

Ben

Sub findoutlier()
Dim strCell As String
Dim strRange As String
Dim x As Long
Dim rRange As Range


For x = 0 To 29
'Assumes that each column has the same number of rows
Set rRange = Range("A1:A43").Offset(0, x)
strCell = "$" & Replace(rRange.Range("A1").Address, "$", vbNullString, 1)
strRange = Replace(rRange.Address, "$", vbNullString, 1)
Debug.Print strCell & vbCr & strRange

With rRange
.Select
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=AND(" & strCell & " <> ""."", OR(" & _
strCell & "<(QUARTILE(" & strRange & ", 1)-1.5*(QUARTILE(" & _
strRange & ", 3)-QUARTILE(" & strRange & ", 1))), " & _
strCell & ">(QUARTILE(" & strRange & ", 1)+1.5*(QUARTILE(" & _
strRange & ", 3)-QUARTILE(" & strRange & ", 1)))))"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
Next x

End Sub