Excel代码问题，非常感谢!

LSYYLW

2024-11-13.zip (8.63 KB, 下载次数: 4)

2024-11-13 08:16 上传

点击文件名下载附件

loirol

这类比英语论文还难懂的需求到底是拿去干嘛的？而且这类需求的提问人统一的都是xls的后缀

z865593849

搞不懂这玩意拿来干嘛的，写了也是白写

loirol

z865593849 发表于 2024-11-13 08:23
搞不懂这玩意拿来干嘛的，写了也是白写

そうですね

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 Else drr(i, 1) = 0
            s = s & CStr(drr(i, 1))
            crr(i, 1) = 0
        Next
        ReDim brr(1 To UBound(arr), 1 To 2)
   
        For i = 1 To UBound(drr)
            If drr(i, 1) > 0 Then
                x = InStr(i, s, "000")
                If x Then
                    n = n + 1
                    brr(n, 1) = i
                    brr(n, 2) = x - 1
                    i = x
                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
        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
        Beep
    End If
    Application.EnableEvents = True
End Sub
   

LSYYLW

quqiyuan 发表于 2024-11-13 08:55
参与一下，仅供参考。。。

万万分的感谢老师，代码非常非常好用，鲜花稍后为您献上。

dragonthree

居然有人能看懂