Excel代码问题，非常感谢！

LSYYLW

2024-10-30--.zip (19.65 KB, 下载次数: 2)

2024-10-30 14:27 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-10-30 13:41
代码如下。。。
   
Private Sub Worksheet_Change(ByVal Target As Range)

非常感谢老师，代码非常好用，还有一点问题麻烦老师您帮我解决一下，麻烦老师您看一下21楼附件里有颜色单元格里的文字，帮我解决一下，拜托了！

quqiyuan

LSYYLW 发表于 2024-10-30 14:30
非常感谢老师，代码非常好用，还有一点问题麻烦老师您帮我解决一下，麻烦老师您看一下21楼附件里有颜色单 ...

quqiyuan

代码如下。。。
   
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$BF$1" Then
        arr = [bf182:bf821]
        brr = [bi1:bm1]
        ReDim crr(1 To 10000, 1 To UBound(brr, 2))
        For j = 1 To UBound(brr, 2)
            x = brr(1, j): n = 0
            For i = UBound(arr) - x + 1 To 1 Step -x
                n = n + 1
                crr(n, j) = arr(i, 1)
            Next
            y = Application.Max(y, n)
        Next
        ReDim drr(1 To y, 1 To UBound(brr, 2))
        For i = 1 To UBound(brr, 2)
            n = 0
            For j = y To 1 Step -1
                n = n + 1
                drr(n, i) = crr(j, i)
            Next
        Next
        Cells(642, "bi").CurrentRegion.ClearContents
        Cells(642 - y + 1, "bi").Resize(y, UBound(brr, 2)) = drr
    End If
    Application.EnableEvents = True
End Sub

LSYYLW

quqiyuan 发表于 2024-10-30 15:31

万分的感谢老师，代码非常非常好用，完美的解决了。

LSYYLW

2024-10-31--.zip (12.69 KB, 下载次数: 2)

2024-10-31 14:38 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-10-29 11:33
参与一下，仅供参考。。。

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

无雨谷

问题一个接一个

quqiyuan

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

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$P$1" Then
        arr = [k10:k72]
        ReDim brr(1 To UBound(arr), 1 To 2)
   
        For i = 1 To UBound(arr) - 1
            If arr(i, 1) > 1 Then
                n = n + 1
                For j = i + 1 To UBound(arr) - 1
                    If arr(j, 1) = 1 Then
                        brr(j, 2) = n
                        i = j
                        n = 0
                        Exit For
                    Else
                        If arr(j, 1) = 0 And arr(j + 1, 1) > 1 Then n = n + 1
                    End If
                Next
                x = i + 1
                If UBound(arr) = x Then
                    If arr(x, 1) > 1 Then brr(x, 2) = n
                End If
            End If
        Next
        For i = 1 To UBound(arr) - 1
            If arr(i, 1) > 1 Then
                brr(i, 1) = m
                m = 0
            ElseIf arr(i, 1) = 1 Then
                m = m + 1
            End If
            x = i + 1
            If UBound(arr) = x Then
                If arr(x, 1) = 0 Or arr(x, 1) = 1 Then brr(x, 1) = m + arr(x, 1)
            End If
        Next
        For i = 1 To UBound(brr)
            For j = 1 To 2
                If brr(i, j) = Empty Then brr(i, j) = 0
            Next
        Next
        [p10].Resize(UBound(brr), 2) = brr
    End If
    Application.EnableEvents = True
End Sub