I'm trying to programmatically highlight cells in a selected range if the cells are greater than than the upper limit or less than the lower limit.

I'm already able to highlight the entire selection, but in trying to highlight the specific cell values which exceed the limit values I end up getting Error 7. Any suggestions on how to do correct this?

Code below and image of data below too:

Sub Data_Prep()
'Identify Outliers

'Specify Dims.....
Dim ws_instruction As Worksheet
Dim ws_data As Worksheet
Dim ws_output As Worksheet
Dim selectedRng As Range
Dim record_cell As Variant
Dim Upper_limit As Variant
Dim Lower_limit As Variant
Dim AnswerYes As String
Dim AnswerNo As String

'Ascribe worksheets
Set ws_instruction = ThisWorkbook.Worksheets("Instruction Sheet")
Set ws_data = ThisWorkbook.Worksheets("Data Sheet")
Set ws_output = ThisWorkbook.Worksheets("Output Sheet")

Set selectedRng = Application.Selection
'Error handling to capture Cancel key.
On Error GoTo errHandler
'Define range.
Set selectedRng = Application.InputBox("Range", , selectedRng.Address, Type:=8)
record_cell = selectedRng.Address(ReferenceStyle:=xlA1, _
                           RowAbsolute:=False, ColumnAbsolute:=False)
Cells(1, 9).Value = record_cell
Cells(1, 10).Value = record_cell

'Format Output Information
ws_output.Cells(4, 1).Value = "Upper Limit"
ws_output.Cells(5, 1).Value = "Lower Limit"


'Limits for the Selected Array
Upper_limit = 52
Lower_limit = 13

ws_output.Cells(4, 2).Value = Upper_limit
ws_output.Cells(5, 2).Value = Lower_limit

On Error GoTo errHandler
'Do something to the selected or input range.
With selectedRng.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535 'Same as RGB(255,255,0)
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

With selectedRng.Interior
    If Cells.Value > Upper_limit Or cell.Value < Lower_limit Then
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65280 'Same as RGB(255,0,0)
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End If
End With

'Stop before running error handling.
Exit Sub
errHandler:
'Quit sub procedure when user clicks InputBox Cancel button.
If Err.Number = 424 Then
    Exit Sub
Else: MsgBox "Error: " & Err.Number, vbOK
End If
End Sub

CodePudding user response：

You need to loop through and test each cell, not the entire selectedRng range. Insert this code... where you're testing the values and you should be good.

Dim aCell As Range
For Each aCell In selectedRng.Cells
   With aCell
   If .Value > Upper_limit Or .Value < Lower_limit Then
     With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65280 'Same as RGB(255,0,0)
        .TintAndShade = 0
        .PatternTintAndShade = 0
      End With
    End If
End With
Next aCell

So your final output would be this...

Sub Data_Prep()
'Identify Outliers

'Specify Dims.....
Dim ws_instruction As Worksheet
Dim ws_data As Worksheet
Dim ws_output As Worksheet
Dim selectedRng As Range
Dim record_cell As Variant
Dim Upper_limit As Variant
Dim Lower_limit As Variant
Dim AnswerYes As String
Dim AnswerNo As String

'Ascribe worksheets
Set ws_instruction = ThisWorkbook.Worksheets("Instruction Sheet")
Set ws_data = ThisWorkbook.Worksheets("Data Sheet")
Set ws_output = ThisWorkbook.Worksheets("Output Sheet")

Set selectedRng = Application.Selection
'Error handling to capture Cancel key.
On Error GoTo errHandler
'Define range.
Set selectedRng = Application.InputBox("Range", , selectedRng.Address, Type:=8)
record_cell = selectedRng.Address(ReferenceStyle:=xlA1, _
                           RowAbsolute:=False, ColumnAbsolute:=False)
Cells(1, 9).Value = record_cell
Cells(1, 10).Value = record_cell

'Format Output Information
ws_output.Cells(4, 1).Value = "Upper Limit"
ws_output.Cells(5, 1).Value = "Lower Limit"


'Limits for the Selected Array
Upper_limit = 52
Lower_limit = 13

ws_output.Cells(4, 2).Value = Upper_limit
ws_output.Cells(5, 2).Value = Lower_limit

On Error GoTo errHandler
'Do something to the selected or input range.
With selectedRng.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 65535 'Same as RGB(255,255,0)
    .TintAndShade = 0
    .PatternTintAndShade = 0
End With

Dim aCell As Range
For Each aCell In selectedRng.Cells
   With aCell
   If .Value > Upper_limit Or .Value < Lower_limit Then
     With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65280 'Same as RGB(255,0,0)
        .TintAndShade = 0
        .PatternTintAndShade = 0
      End With
    End If
End With
Next aCell


'Stop before running error handling.
Exit Sub
errHandler:
'Quit sub procedure when user clicks InputBox Cancel button.
If Err.Number = 424 Then
    Exit Sub
Else: MsgBox "Error: " & Err.Number, vbOK
End If
End Sub

Cleaner Method

Also if you just want a cleaner way to do something like this consider this type of code...

Sub highlightstuff()
Const yesColor As Long = 65280
Const noColor As Long = 65535
Const Lower_limit As Long = 13
Const Upper_limit As Long = 52

Dim yesRange As Range, noRange As Range, allRange As Range, aCell As Range
Set allRange = Selection '<--- probably not a good ide


For Each aCell In allRange.Cells

   If IsNumeric(aCell) Then ' maybe you don't need this...
      If aCell.Value > Upper_limit Or aCell.Value < Lower_limit Then
         If yesRange Is Nothing Then
            Set yesRange = aCell
         Else
            Set yesRange = Union(aCell, yesRange)
         End If
      Else
         If noRange Is Nothing Then
            Set noRange = aCell
         Else
            Set noRange = Union(aCell, noRange)
         End If
      End If
   End If
Next aCell

yesRange.Interior.Color = yesColor
noRange.Interior.Pattern = noColor

End Sub