Excel代码问题，非常感谢！

LSYYLW

2024-10-2.zip (5.15 KB, 下载次数: 6)

2024-10-2 09:46 上传

点击文件名下载附件

3190496160

Sub 判断提取()
Dim ar As Variant
Range("aa14:am104") = 0
ar = Range("m14:am105")
For j = 1 To 13
    gs = 0
    For i = 1 To UBound(ar)
        If ar(i, j) = 0 Then
            ks = i
            For s = i + 1 To UBound(ar)
                If ar(s, j) <> 0 Then
                    js = s
                    Exit For
                End If
            Next s
            gs = js - ks
            If gs > 3 Then
                ar(js, j + 14) = ar(js, j)
            End If
        End If
    Next i
Next j
Range("m14:am105") = ar
MsgBox "ok!"
End Sub

3190496160

2024-10-2.rar (14.65 KB, 下载次数: 1)

2024-10-2 10:16 上传

点击文件名下载附件

3190496160

结果未认真核对，代码仅供参考

quqiyuan

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

quqiyuan

代码如下。。。

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Target.Address = "$Z$1" Then
        arr = [m14:y105]
        ReDim brr(1 To UBound(arr) - 1, 1 To UBound(arr, 2))
        For j = 1 To UBound(arr, 2)
            t = False: n = 0
            For i = 1 To UBound(arr)
                If arr(i, j) = 0 Then
                    n = n + 1
                    If t = True Then brr(i - 1, j) = arr(i - 1, j): t = False
                Else
                    If n > 3 Then
                        t = True
                    End If
                    n = 0
                End If
            Next
        Next
        For i = 1 To UBound(brr)        '此处为了填充0
            For j = 1 To UBound(brr, 2)
                If Len(brr(i, j)) = 0 Then brr(i, j) = 0
            Next
        Next
        [aa14].Resize(UBound(brr), UBound(brr, 2)) = brr
        Beep
    End If
    Application.EnableEvents = True
End Sub

LSYYLW

3190496160 发表于 2024-10-2 10:14
Sub 判断提取()
Dim ar As Variant
Range("aa14:am104") = 0

非常感谢老师！

LSYYLW

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

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

yynrzwh

初始化为0：
dim ar() as integer

LSYYLW

2024-10-4.zip (5.74 KB, 下载次数: 3)

2024-10-4 15:05 上传

点击文件名下载附件