求修改代码

hfvung

复制和间隔粘贴，详情请看附件： 求修改代码AB.rar (12.89 KB, 下载次数: 6)

2024-8-10 17:10 上传

点击文件名下载附件

quqiyuan

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

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, j&, n&
   
    Application.ScreenUpdating = False
   
    With Worksheets(2).[B2].CurrentRegion
        ReDim ar(1 To .Columns.Count)
        For j = 1 To UBound(ar)
            Set ar(j) = .Columns(j)
        Next j
    End With
   
    With Worksheets(1)
        With [U1]
            For j = 1 To UBound(ar)
                n = (j - 1) * 6 + 1
                ar(j).Copy .Cells(, n)
            Next j
        End With
        .Activate
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。