Excel代码问题，非常感谢！

quqiyuan

LSYYLW 发表于 2024-11-7 23:01
老师您好：又来麻烦您了，您有时间帮我看一下19楼附件里的问题，帮我解决一下，拜托您了！

今天重构了代码，花了一些时间，仅供参考。。。

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$D$1" Then
        arr = [b11:b140]
        ReDim crr(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr)
            If Len(arr(i, 1)) > 1 Then arr(i, 1) = Mid(arr(i, 1), 1, 1)
            s = s & CStr(arr(i, 1))
            crr(i, 1) = 0
        Next
        ReDim brr(1 To UBound(arr), 1 To 2)
   
        For i = 1 To UBound(arr)
            If arr(i, 1) > 0 Then
                '            For j = i To Len(s)
                x = InStr(i, s, "000")
                If x Then
                    n = n + 1
                    brr(n, 1) = i
                    brr(n, 2) = x - 1
                    i = x
                    '                    Exit For
                Else
                    n = n + 1
                    brr(n, 1) = i
                    For k = UBound(arr) To i Step -1
                        If arr(k, 1) <> 0 Then Exit For
                    Next
                    brr(n, 2) = k
                    i = UBound(arr)
                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(arr(k, 1) > 0, 1, 0)
                Next
                For k = brr(i, 1) To brr(i, 2)
                    crr(k, 1) = x
                Next
            End If
        Next
        [d11].Resize(UBound(brr)) = crr
        Beep
    End If
    Application.EnableEvents = True
End Sub
   

LSYYLW

2024-11-8---.zip (16.73 KB, 下载次数: 2)

2024-11-8 19:12 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-11-8 16:28
今天重构了代码，花了一些时间，仅供参考。。。

万万分的感谢老师，非常抱歉，为了我的问题，耽误了您宝贵的时间，让您受累了，老师您休息一下，明天您有时间再帮我看一下23楼附件里有颜色单元格里的文字，帮我解决一下，拜托了！

quqiyuan

这个你测试一下，仅供参考。。。

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$D$1" Then
        arr = [b11:b140]
        ReDim crr(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr)
            If arr(i, 1) > 0 Then arr(i, 1) = 1 Else arr(i, 1) = 0
            s = s & CStr(arr(i, 1))
            crr(i, 1) = 0
        Next
        ReDim brr(1 To UBound(arr), 1 To 2)
   
        For i = 1 To UBound(arr)
            If arr(i, 1) > 0 Then
                x = InStr(i, s, "000")
                y = InStr(i, s, "100")
                Z = InStr(i, s, "0100")
                zz = InStr(i, s, "0010")
                m = Application.Min(Z, zz)
                If i = y Then
                    i = i + 2
                Else
                    If x <= m And x > 0 Then
                        n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = x - 1
                        i = x
                    ElseIf x = 0 And Z = 0 And zz = 0 Then
                        n = n + 1
                        brr(n, 1) = i
                        For k = UBound(arr) To i Step -1
                            If arr(k, 1) <> 0 Then Exit For
                        Next
                        brr(n, 2) = k
                        i = UBound(arr)
                    ElseIf x = 0 And m > 0 Then
                         n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = m - 1
                        i = m
                    ElseIf x > m And x > 0 And Z < zz Then
                        n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = Z + 1
                        i = Z
                    ElseIf x > m And x > 0 And Z > zz Then
                        n = n + 1
                        brr(n, 1) = i
                        brr(n, 2) = zz - 1
                        i = zz
                    End If
                End If
            End If
        Next
        For i = 1 To n
            x = 0
            If brr(i, 2) - brr(i, 1) >= 4 Then
                For k = brr(i, 1) To brr(i, 2)
                    x = x + IIf(arr(k, 1) > 0, 1, 0)
                Next
                If x >= 5 Then
                    For k = brr(i, 1) To brr(i, 2)
                        crr(k, 1) = x
                    Next
                End If
            End If
        Next
        [d11].Resize(UBound(brr)) = crr
'        [k11].Resize(UBound(brr), 2) = brr
        Beep
    End If
    Application.EnableEvents = True
End Sub
   

LSYYLW

quqiyuan 发表于 2024-11-15 20:15
这个你测试一下，仅供参考。。。

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