数值区间比对

cmo9020

请教导师一下,我现在写了一个代码,但是现在只有b列能用
B3单元格是数值区间
执行之后B4列会对B3单元格做比对,如果数值在B3区间会维持不变
若是低于或高于则会粗体+反红
现在延申要让后面每一列都相同,像这样到AZ列,要如何修改?
C4列会对C3单元格做比对
D4列会对D3单元格做比对
E4列会对E3单元格做比对
后面每列都要像这样到AZ列

还是有什么更快的代码可以提供,谢谢各位导师

Sub CompareValues()
    ' 宣告变量
    Dim targetRange As Range
    Dim compareRange As Range
    Dim cell As Range
    Dim targetValue As Double
    Dim compareValue As Double
    Dim originalFont As Font
   
Range("B4:AZ100").Font.Bold = False
Range("B4:AZ100").Font.ColorIndex = xlAutomatic



    ' 设定目标范围和比较范围
    Set targetRange = Range("B3")
    Set compareRange = Range("B4:B" & Cells(Rows.Count, "B").End(xlUp).Row)
   
    ' 读取目标值
    targetValue = CDbl(Split(targetRange.Value, "~")(0))
   
    ' 遍历比较范围
    For Each cell In compareRange
        ' 如果单元格不是空白的
        If Not IsEmpty(cell) And IsNumeric(cell.Value) Then
            ' 储存原始字体格式
            Set originalFont = cell.Font
            ' 读取比较值
            compareValue = CDbl(cell.Value)
            
            ' 如果比较值小于或大于目标值
            If compareValue < targetValue Or compareValue > CDbl(Split(targetRange.Value, "~")(1)) Then
                ' 设定字体为粗体和红色
                cell.Font.Bold = True
                cell.Font.Color = RGB(255, 0, 0)
            Else ' 如果比较值在目标范围内
                ' 恢复原始字体格式
                cell.Font.Name = originalFont.Name
                cell.Font.Size = originalFont.Size
            End If
        End If
    Next cell
End Sub

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet1")
   
5.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
6.         c = .Cells(3, .Columns.Count).End(xlToLeft).Column
   
7.         arr = .Range("a1").Resize(r, c)
   
8.         For j = 2 To UBound(arr, 2)
   
9.             xm = Split(arr(3, j), "~")
   
10.             n1 = Val(xm(0))
    
11.             n2 = Val(xm(1))
    
12.             For i = 4 To UBound(arr)
    
13.                 If arr(i, j) < n1 Or arr(i, j) > n2 Then
    
14.                     With .Cells(i, j).Font
    
15.                         .ColorIndex = 3
    
16.                         .Bold = True
    
17.                     End With
    
18.                 End If
    
19.             Next
    
20.         Next
    
21.     End With
    
22. End Sub
    

复制代码

chxw68

详见附件。

准提部林

B4//格式化條件
=--TEXT(B4,"[<"&SUBSTITUTE(B$3,"~","]1;[>")&"]1;\0")

輸入數字立即體現~~

cmo9020

chxw68 发表于 2023-4-29 10:24
详见附件。

谢谢导师还找了相关的解答参考
非常感谢您~祝您假日愉快