Excel代码问题，非常感谢！

LSYYLW

quqiyuan 发表于 2024-12-14 11:01
代码如下。。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents  ...

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

LSYYLW

2024-12-14---.zip (20.44 KB, 下载次数: 3)

2024-12-14 15:58 上传

点击文件名下载附件

quqiyuan

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

quqiyuan

代码如下。。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$H$1" Then
        s = ""
        arr = [e51:e335]
        crr = arr
        If crr(UBound(crr), 1) = Empty Then crr(UBound(crr), 1) = 0
        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 = 2 To UBound(crr)
            If crr(i, 1) = 0 Then
                If crr(i - 1, 1) <> 0 Then
                    For j = i - 1 To 2 Step -1
                        If crr(j, 1) = 0 Then
                            If crr(j - 1, 1) <> 0 And crr(j - 1, 1) = crr(i - 1, 1) Then
                                brr(i, 0) = crr(i - 1, 1)
                                Exit For
                            Else
                                Exit For
                            End If
                        End If
                    Next
                End If
            End If
        Next
        [h51].Resize(UBound(brr)) = brr
        s = ""
        arr = [k51:k335]
        crr = arr
        If crr(UBound(crr), 1) = Empty Then crr(UBound(crr), 1) = 0
        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 = 2 To UBound(crr)
            If crr(i, 1) = 0 Then
                If crr(i - 1, 1) <> 0 Then
                    For j = i - 1 To 2 Step -1
                        If crr(j, 1) = 0 Then
                            If crr(j - 1, 1) <> 0 And crr(j - 1, 1) = crr(i - 1, 1) Then
                                brr(i, 0) = crr(i - 1, 1)
                                Exit For
                            Else
                                Exit For
                            End If
                        End If
                    Next
                End If
            End If
        Next
        [p51].Resize(UBound(brr)) = brr
        Beep
    End If
    Application.EnableEvents = True
End Sub

LSYYLW

quqiyuan 发表于 2024-12-14 17:14
参与一下，仅供参考。。。。

再次万分的感谢老师，我又增加了几个条件，进行了测试，效果非常非常好，完全满足我的需求。