Excel2003代码问题，非常感谢！

quqiyuan

有点问题，条件太多，有时候考虑没那么周到，等一下改好。。。。

quqiyuan

代码如下。。。。

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$Q$1" Then
        arr = [h11:h140]
        br = [n11:n140]
        ReDim crr(1 To UBound(arr), 1 To 1)
        ReDim drr(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr)
            If arr(i, 1) > 0 And br(i, 1) > 0 Then
                drr(i, 1) = 1
            ElseIf arr(i, 1) > 0 And br(i, 1) = 0 Then
                drr(i, 1) = 2
            Else
                drr(i, 1) = 0
            End If
            crr(i, 1) = 0
            s = s & CStr(drr(i, 1))
        Next
        ReDim brr(1 To UBound(arr), 1 To 2)
        For i = 1 To UBound(drr)
            If drr(i, 1) = 1 Then
                x = InStr(i, s, "2")
                y = InStr(i, s, "000")
                Z = InStr(i, s, "02")
                zz = InStr(i, s, "002")
                If x < y And y > 0 Or x > y And y = 0 Then
                    If zz = x - 2 Then
                        n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = x - 3
                        i = x
                    ElseIf Z = x - 1 Then
                        n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = x - 2
                        i = x
                    Else
                        n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = x - 1
                        i = x
                    End If
                ElseIf x > y And y > 0 Then
                        n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = y - 1
                        i = y
                Else
                    If y Then
                        n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = y - 1
                        i = y
                    Else
                        n = n + 1
                        brr(n, 1) = i
                        For k = UBound(drr) To i Step -1
                            If drr(k, 1) <> 0 Then Exit For
                        Next
                        brr(n, 2) = k
                        i = UBound(drr)
                    End If
                End If
            End If
        Next
        For i = 1 To n
            x = 0
            If brr(i, 2) - brr(i, 1) >= 3 Then
                For k = brr(i, 1) To brr(i, 2)
                    x = x + IIf(drr(k, 1) > 0, 1, 0)
                Next
                If x > 3 Then
                    For k = brr(i, 1) To brr(i, 2)
                        crr(k, 1) = x
                    Next
                End If
            End If
        Next
        [q11].Resize(UBound(brr)) = crr
'        [w11].Resize(UBound(brr), 2) = brr
        Beep
    End If
    Application.EnableEvents = True
End Sub

quqiyuan

这次应该是差不多了，仅供参考测试。。。

quqiyuan

文件如下。。。

LSYYLW

quqiyuan 发表于 2024-11-16 10:52
文件如下。。。

万万分的感谢老师，代码非常非常好用，您完美的为我解决了问题，让您受累了。