VBA 比更小值及标示

On_fire

VBA 比更小值及标示

*

Sheet1是源数据, [V14: Y27]要比较的数据

*暂时删掉不参加处理的数据

*

代码的逻辑如下,

1.      先分开左右两组, 再V对比X列, W对比Y列

2.      先对比格內左侧值, 如更小, 单元格底色标黄

3.      如果左值相同, 对比括号()内的值, 如更小, 单元格底色标绿

*

Sheet1(1)是模拟结果

*

恳请大神, 老师帮忙…谢谢…!!!

liulang0808

Sub 按钮1_Click()
    Set rn1 = Nothing
    Set rn2 = Nothing
    Application.ScreenUpdating = False
    For j = 14 To 27
        Call compar_cells(Cells(j, "v"), Cells(j, "x"), rn1, rn2)
        Call compar_cells(Cells(j, "w"), Cells(j, "y"), rn1, rn2)
    Next j
    If Not rn1 Is Nothing Then
        rn1.Interior.ColorIndex = 6
    End If
    If Not rn2 Is Nothing Then
        rn2.Interior.ColorIndex = 8
    End If
    Application.ScreenUpdating = True
End Sub
Sub compar_cells(rna, rnb, rn1, rn2)
    If rna <> rnb Then
        If Val(rna) > Val(rnb) Then
            If rn1 Is Nothing Then
                Set rn1 = rnb
            Else
                Set rn1 = Union(rn1, rnb)
            End If
        Else
            If Val(rna) < Val(rnb) Then
                If rn1 Is Nothing Then
                    Set rn1 = rna
                Else
                    Set rn1 = Union(rn1, rna)
                End If
            Else
                x = Val(Replace(Split(rna, "(")(1), "*", ""))
                y = Val(Replace(Split(rnb, "(")(1), "*", ""))
                If x > y Then
                    If rn2 Is Nothing Then
                        Set rn2 = rnb
                    Else
                        Set rn2 = Union(rn2, rnb)
                    End If
                Else
                    If x < y Then
                        If rn2 Is Nothing Then
                            Set rn2 = rna
                        Else
                            Set rn2 = Union(rn2, rna)
                        End If
                    End If
                End If
            End If
        End If
    End If
End Sub

liulang0808

供参考。。。。。。

On_fire

liulang0808 发表于 2023-2-27 10:48
供参考。。。。。。

厉害, 感谢版主出手帮忙…

liulang0808

On_fire 发表于 2023-2-27 11:22
厉害, 感谢版主出手帮忙…

希望楼主也在空暇时间，帮帮其他提问者。

准提部林

Sub TEST_A1()
Dim A As Range, j%, k%, T1, T2, V%, V1%, V2%, C%
With Range("V14:Y27")
     .Interior.ColorIndex = 0
     For Each A In .Columns(1).Cells
         For k = 1 To 2
             T1 = Replace(A(1, k), "*", "")
             T2 = Replace(A(1, k + 2), "*", "")
             V1 = Format(Val(T1) - Val(T2), "3;1;0")
             V2 = Format(Val(Split(T1, "(")(1)) - Val(Split(T2, "(")(1)), "3;1;0")
             If V1 > 0 Then V = V1: C = 6 Else V = V2: C = 43
             If V > 0 Then A(1, V + k - 1).Interior.ColorIndex = C: V = 0
         Next k
     Next A
End With
End Sub

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, i&, j&, Rng As Range
   
    Set Rng = [V14].CurrentRegion
    With Rng
        .Interior.ColorIndex = 0
        ar = .Value
    End With
   
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "(\d+).*?\(.*?(\d+).*?\)"
        For j = 1 To 2
            For i = 1 To UBound(ar)
                Set ar(i, j) = .Execute(ar(i, j))
                Set ar(i, j + 2) = .Execute(ar(i, j + 2))
                If ar(i, j)(0).submatches(0) < ar(i, j + 2)(0).submatches(0) Then
                    Rng.Cells(i, j).Interior.ColorIndex = 6
                ElseIf ar(i, j + 2)(0).submatches(0) < ar(i, j)(0).submatches(0) Then
                    Rng.Cells(i, j + 2).Interior.ColorIndex = 6
                Else
                    If ar(i, j)(0).submatches(1) < ar(i, j + 2)(0).submatches(1) Then Rng.Cells(i, j).Interior.ColorIndex = 43
                    If ar(i, j + 2)(0).submatches(1) < ar(i, j)(0).submatches(1) Then Rng.Cells(i, j + 2).Interior.ColorIndex = 43
                End If
            Next i
        Next j
    End With

    Beep
End Sub

gwjkkkkk

参与一下。。。