Excel代码问题，非常感谢！

LSYYLW

2024-9-22.zip (9.95 KB, 下载次数: 5)

2024-9-22 12:20 上传

点击文件名下载附件

quqiyuan

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

quqiyuan

代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$S$1" Then Exit Sub
    Application.EnableEvents = False
    arr = [g8:q66]
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    ReDim crr(1 To 8, 1 To UBound(arr, 2))
    For j = 1 To UBound(arr, 2)
        n = 0
        For i = 1 To UBound(arr) - 1
            If arr(i, j) = 0 Then
                n = n + 1
                brr(n, j) = 0
            ElseIf arr(i, j) <> 0 And arr(i + 1, j) = 0 Then
                n = n + 1
                brr(n, j) = arr(i, j)
            End If
            If i + 1 = UBound(arr) Then
                n = n + 1
                brr(n, j) = arr(i + 1, j)
            End If
        Next
        m = 9
        For i = n To 1 Step -1
            m = m - 1
            If m > 0 Then
                crr(m, j) = brr(i, j)
            Else
                Exit For
            End If
        Next
    Next
    [v51].Resize(8, UBound(crr, 2)) = crr
    Application.EnableEvents = True
End Sub

cidanji

LSYYLW

quqiyuan 发表于 2024-9-22 13:45
参与一下，仅供参考。。。

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

LSYYLW

cidanji 发表于 2024-9-22 14:11

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