Excel代码问题，非常感谢！

LSYYLW

2024-7-19.zip (13.18 KB, 下载次数: 7)

2024-7-18 08:21 上传

点击文件名下载附件

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$E$1" Then
        arr = [f9:f108]
        [j9].CurrentRegion.ClearContents
        ReDim brr(1 To UBound(arr), 1 To 10)
        For i = 1 To UBound(arr)
            brr(i, arr(i, 1)) = 0
            For j = 1 To 10
                If i = 1 Then
                    If Len(brr(i, j)) = 0 Then brr(i, j) = 1
                Else
                    If Len(brr(i, j)) = 0 Then brr(i, j) = brr(i - 1, j) + 1
                End If
            Next
        Next
        Beep
        [j9].Resize(UBound(arr), 10) = brr
    End If
End Sub

kyxfyzg

Sub test()
arr = Range("j9:s108")
brr = WorksheetFunction.Transpose(Range("f9:f108"))
Range("j9:s108").ClearContents
For i = 1 To UBound(arr, 2)
    For j = 1 To UBound(arr)
        arr(j, i) = j
    Next j
Next i

For i = 1 To UBound(brr)
    For j = i To UBound(arr)
        arr(j, brr(i)) = j - i
    Next j
Next i
Range("j9:s108") = arr
End Sub

yynrzwh

2024-7-19.zip (13.29 KB, 下载次数: 3)

2024-7-18 11:29 上传

点击文件名下载附件

LSYYLW

quqiyuan 发表于 2024-7-18 08:57
参与一下，供参考。。。

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

LSYYLW

kyxfyzg 发表于 2024-7-18 09:53
Sub test()
arr = Range("j9:s108")
brr = WorksheetFunction.Transpose(Range("f9:f108"))

非常感谢老师!

LSYYLW

yynrzwh 发表于 2024-7-18 11:29

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