VBA 突出显示边界条件外范围内的单元格

Posted 2023-03-06

【中文标题】VBA 突出显示边界条件外范围内的单元格

【英文标题】：VBA Highlight Cells in Range Outside of Boundary Conditions

【发布时间】：2022-01-10 14:00:40

【问题描述】：

如果单元格大于上限或小于下限，我正在尝试以编程方式突出显示选定范围内的单元格。

我已经能够突出显示整个选择，但是在尝试突出显示超出限制值的特定单元格值时，我最终得到了错误 7。关于如何更正此问题的任何建议？

下面的代码和下面的数据图像：

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

【参考方案1】：

您需要循环并测试每个单元格，而不是整个selectedRng 范围。插入此代码...您正在测试值的地方，您应该很好。

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

所以你的最终输出将是这个......

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

清理方法

此外，如果您只是想要一种更简洁的方式来执行此类操作，请考虑使用这种类型的代码...

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