Search code examples
excelvbahighlight

VBA Highlight Cells in Range Outside of Boundary Conditions


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

enter image description here


Solution

  • 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