复列数据到工作薄的问题

杨小妹

附件 复制列数据到工作薄附件.rar (681.01 KB, 下载次数: 8)

2024-9-15 09:24 上传

点击文件名下载附件

谢谢老师！

gwjkkkkk

Option Explicit
Sub test()
    Dim ar(), i&, j&, strFileName$, strPath$, n&
   
    Application.ScreenUpdating = False
  
    With Worksheets(2)
        With .[A1].CurrentRegion
            n = .Columns.Count
            ReDim ar(1 To 2, 1 To n)
            For j = 1 To n
                Set ar(1, j) = .Columns(j)
            Next j
        End With
    End With
    With Worksheets(3)
        With .[A1].CurrentRegion
            n = .Columns.Count
            For j = 1 To n
                Set ar(2, j) = .Columns(j)
            Next j
        End With
    End With
   
    n = 0
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xlsb")
    Do Until strFileName = ""
        n = n + 1
        With Workbooks.Open(strPath & strFileName)
            With .Worksheets(1)
                ar(1, n).Copy .[D1]
                ar(2, n).Copy .[E1]
            End With
            .Close True
        End With
        strFileName = Dir
    Loop
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。。。。