Excel代码问题，非常感谢！

gwjkkkkk

参与一下。。。

LSYYLW

quqiyuan 发表于 2024-10-14 19:37
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents =  ...

再次感谢老师，代码非常好用，鲜花明天为您献上。

LSYYLW

gwjkkkkk 发表于 2024-10-14 19:43
参与一下。。。

非常感谢老师，代码非常好用，鲜花明天为您献上。

LSYYLW

2024-11-7.zip (3.32 KB, 下载次数: 2)

2024-11-7 15:41 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-10-14 19:37
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents =  ...

老师您好：又来麻烦您了，您有时间帮我看一下14楼附件里的问题，帮我解决一下，拜托了！

quqiyuan

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

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

quqiyuan

代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$D$1" Then
        arr = [b11:b110]
        ReDim brr(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr) - 1
            If arr(i, 1) > 0 Then
                n = 1: m = 1
                For j = i + 1 To UBound(arr) - 1
                    If arr(j, 1) > 0 And j + 1 <> UBound(arr) Then
                        n = n + 1: m = m + 1
                    ElseIf arr(j, 1) = 0 And arr(j + 1, 1) > 0 And j + 1 <> UBound(arr) Then
                        '                    If arr(j, 1) > 0 Then n = n + 1
                        m = m + 1
   
                    ElseIf j + 1 = UBound(arr) Then
                        If arr(j, 1) > 0 And m > 1 Then If arr(j + 1, 1) > 0 Then m = m + 2: n = n + 2 Else m = m + 1: n = n + 1
                        If m > 3 Then
                            For k = i To i + m - 1
                                brr(k, 1) = n
                            Next
                        End If
                        i = j
                        Exit For
                    Else                                       'If j + 1 <> UBound(arr) Then
                        If m > 3 Then
                            For k = i To j - 1
                                brr(k, 1) = n
                            Next
                        End If
                        i = j
                        Exit For
                    End If
                Next
            End If
        Next
        For i = 1 To UBound(brr)
            If brr(i, 1) = Empty Then brr(i, 1) = 0
        Next
        [d11].Resize(UBound(brr)) = brr
        Beep
    End If
    Application.EnableEvents = True
End Sub
   

LSYYLW

quqiyuan 发表于 2024-11-7 20:46
参与一下，仅供参考。。。

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

LSYYLW

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

2024-11-7 22:59 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-11-7 20:47
代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)

老师您好：又来麻烦您了，您有时间帮我看一下19楼附件里的问题，帮我解决一下，拜托您了！