麻烦老师帮忙修改代码，实现图中的问题，非常感谢！

LSYYLW

2024-6-25-------.zip (15.79 KB, 下载次数: 6)

2024-6-25 14:46 上传

点击文件名下载附件

longwin

供参考。。。。。

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$CC$1" Then
       arr = Range("CC3:CC" & [CC65536].End(3).Row)
       ReDim brr(1 To UBound(arr), 1 To 1)
       For i = 1 To UBound(arr)
            If IsNumeric(arr(i, 1)) Then
                If arr(i, 1) = "" Then
                    brr(i, 1) = Empty
                Else
                    If i = 1 Then
                        brr(i, 1) = 1
                    Else
                        brr(i, 1) = brr(i - 1, 1) + 1
                    End If
                End If
            Else
                brr(i, 1) = 0
            End If
        Next
        For j = UBound(brr) - 1 To 1 Step -1
           If brr(j, 1) > 0 And brr(j + 1, 1) > 0 Then brr(j, 1) = brr(j + 1, 1)
        Next
        Range("cg3:cg65").ClearContents
        Range("cg3").Resize(UBound(arr), 1) = brr
    End If
End Sub

LSYYLW

quqiyuan 发表于 2024-6-25 15:27
参与一下，供参考。。。

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

LSYYLW

2024-6-28.zip (13.51 KB, 下载次数: 5)

2024-6-25 15:37 上传

点击文件名下载附件

LSYYLW

longwin 发表于 2024-6-25 15:21
供参考。。。。。

非常感谢老师，代码非常好用。再麻烦老师您一下，您有时间帮我看一下6楼附件里的问题，拜托了！

quqiyuan

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

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$AI$1" Then
        arr = Range("ag3:ai33")
        Range("am3:ao33").ClearContents
        For j = 1 To 3
            ReDim brr(1 To UBound(arr), 1 To 1)
            m = 0
            For i = 1 To UBound(arr)
                If arr(i, j) <> "" Then
                    m = m + 1
                    brr(m, 1) = arr(i, j)
                End If
            Next
            Range(Cells(33 - m + 1, 38 + j), Cells(33, 38 + j)) = brr
        Next
    End If
End Sub

LSYYLW

quqiyuan 发表于 2024-6-25 16:12
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$AI$1" ...

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