Excel代码问题，非常感谢！

LSYYLW

2024-7-22.zip (15.13 KB, 下载次数: 6)

2024-7-21 16:14 上传

点击文件名下载附件

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。


Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$BF$1" Then
        [bi579].CurrentRegion.ClearContents
        arr = [bf182:bf821]
        ReDim brr(1 To 1000, 1 To 5)
        ReDim crr(1 To 1000, 1 To 5)
        x = [{9,19,39,79,159}]
        For j = 1 To UBound(x)
            n = 0
            For i = 1 To UBound(arr) Step x(j) + 1
                n = n + 1
                brr(n, j) = arr(i, 1)
            Next
            m = Application.Max(m, n)
            For k = 1 To n
                crr(m - n + k, j) = brr(k, j)
            Next
        Next
        [bi579].Resize(m, 5) = crr
        Beep
    End If
End Sub

gwjkkkkk

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ar, br, cr(), r&
   
    If Target.Address <> "$BF$1" Then Exit Sub
   
    br = [{"BI579",10;"BJ611",20;"BK627",40;"BL635",80;"BM639",160}]
    r = Cells(Rows.Count, "BF").End(xlUp).Row
    ar = Range("BF182:BF" & r).Value
    [BI579].CurrentRegion.ClearContents
   
    Application.EnableEvents = False
        For i = 1 To UBound(br)
            Erase cr: r = 0
            For j = 1 To UBound(ar) Step br(i, 2)
                r = r + 1
                ReDim Preserve cr(1 To r)
                cr(r) = ar(j, 1)
            Next j
            Range(br(i, 1)).Resize(UBound(cr)) = Application.Transpose(cr)
        Next i
    Application.EnableEvents = True
End Sub

gwjkkkkk

。。。。。。。。。。。

LSYYLW

quqiyuan 发表于 2024-7-21 16:57
代码如下。。。

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

LSYYLW

gwjkkkkk 发表于 2024-7-21 16:59
。。。。。。。。。。。

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

LSYYLW

2024-7-23.zip (7.71 KB, 下载次数: 2)

2024-7-21 22:00 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-7-21 16:57
代码如下。。。

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

quqiyuan

参与一下，供参考。。。