Excel代码问题，非常感谢!

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) = 200
                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) Mod 10 = crr(i - 1, 1) Mod 10 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) = 200
                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) Mod 10 = crr(i - 1, 1) Mod 10 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-16 14:07
稍作调整即可，仅供参考。。。

抱歉老师，可能是网站有问题，下载的附件打不开。

LSYYLW

quqiyuan 发表于 2024-12-16 14:07
稍作调整即可，仅供参考。。。

万分的感谢老师，才看到老师您在12楼发的代码，我测试过了，代码非常非常好用，您完美的为我解决了问题。

LSYYLW

chxw68 发表于 2024-12-16 09:29
权当做练习吧。

非常感谢老师，鲜花稍后为您献上。

quqiyuan

LSYYLW 发表于 2024-12-16 14:37
抱歉老师，可能是网站有问题，下载的附件打不开。

今天网站有问题，很多附件都不行。。。

LSYYLW

quqiyuan 发表于 2024-12-16 15:46
今天网站有问题，很多附件都不行。。。

多谢多谢老师，这回下载的附件打开了。