Excel代码问题，非常感谢!

LSYYLW

2024-11-17.zip (7.96 KB, 下载次数: 5)

2024-11-17 08:55 上传

点击文件名下载附件

quqiyuan

参与一下，仅供参考测试。。。。

quqiyuan

代码如下。。。。

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$K$1" Then
        arr = [e211:e850]
        For i = UBound(arr) To 2 Step -1
            If arr(i, 1) > 1 Then arr(i, 1) = 2
        Next
        For i = UBound(arr) To 2 Step -1
            If arr(i, 1) > 0 And arr(i, 1) = arr(i - 1, 1) Then arr(i, 1) = 0
        Next
        s = Join(Application.Transpose(arr), "")
        ReDim brr(1 To 1000)
        For i = 1 To UBound(arr)
            x = InStr(i, s, "1")
            y = InStr(i, s, "2")
            If x < y And x > 0 Then
                cnt = 0
                For j = x To y - 1
                    If arr(j, 1) > 0 Then cnt = cnt + 1
                Next
                n = n + 1
                brr(n) = cnt
                i = y - 1
            ElseIf x > y And y > 0 Then
                cnt = 0
                For j = y To x - 1
                    If arr(j, 1) > 0 Then cnt = cnt + 1
                Next
                n = n + 1
                brr(n) = cnt
                i = x - 1
            ElseIf x < y And x = 0 Or x > y And y = 0 Then
                cnt = 0
                For j = Application.Max(x, y) To UBound(arr)
                    If arr(j, 1) > 0 Then cnt = cnt + 1
                Next
                n = n + 1
                brr(n) = cnt
                i = UBound(arr)
            End If
        Next
        Cells(300 - n + 1, "k").Resize(n) = Application.Transpose(brr)
        Beep
    End If
    Application.EnableEvents = True
End Sub

LSYYLW

quqiyuan 发表于 2024-11-17 15:21
代码如下。。。。

Private Sub Worksheet_Change(ByVal Target As Range)

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