Excel代码问题，非常感谢！

LSYYLW

大灰狼1976 发表于 2024-12-11 12:47

非常感谢老师，代码非常好用。

LSYYLW

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

非常感谢老师，代码非常好用。

LSYYLW

2024-12-12-.zip (9.23 KB, 下载次数: 2)

2024-12-12 10:48 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-12-11 13:01
代码如下。。。。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count  ...

老师您好：今天又来麻烦您了，在您有时间，不耽误您工作和休息的情况下，老师您受累帮我看一下13楼附件里的问题，拜托您了！

LSYYLW

2024-12-13-.zip (5.4 KB, 下载次数: 3)

2024-12-13 13:00 上传

点击文件名下载附件

LSYYLW

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

老师您好：我对向您求助的问题的条件一里的条件进行了完善，附件现已发在15楼，敬请老师您按照这个附件里的条件帮我解决一下，拜托您了！

LSYYLW

quqiyuan 发表于 2024-12-11 13:01
代码如下。。。。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count  ...

老师您好：15楼里的问题我又对显示条件做了重新编写，感觉能比之前的显示条件简单一些，在老师您有时间，不耽误您工作和休息的情况下，老师您受累帮我看一下，拜托您了！

chxw68

结果在I列。

quqiyuan

参与一下，仅供参考。。。
你测试一下，不知道有没有问题。。

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$H$1" Then
        arr = [e51:e251]
        ReDim brr(1 To UBound(arr), 0)
        For i = 1 To UBound(arr)
            If arr(i, 1) > 0 Then
                arr(i, 1) = 1
            Else
                arr(i, 1) = 0
            End If
            s = s & CStr(arr(i, 1))
            brr(i, 0) = 0
        Next
        For i = 1 To Len(s)
            x = InStr(i, s, "000")
            If IsNumeric(x) And x <> 0 Then
                brr(x + 2, 0) = 100
                i = x
            Else
                Exit For
            End If
        Next
        For i = 1 To Len(s)
            x = InStr(i, s, "0")
            y = InStr(i, s, "1")
            If x > y And y > 0 Then
                yy = InStr(Mid(s, x + 1), "1")
                xx = InStr(Mid(s, x + 1), "0")
                If (x - y = xx - yy) Or (x - y = zz) Then
                    i = x + xx - 1
                    If x - y = xx - yy Then
                        brr(i + 1, 0) = xx - 1
                    ElseIf zz > 0 Then
                        brr(i, 0) = zz
                    End If
                    zz = 0
                Else
                    zz = xx - yy
                    i = x + xx - 1
                End If
            
            End If
        Next
        [h51].Resize(UBound(brr)) = brr
        Beep
    End If
    Application.EnableEvents = True
End Sub