批量导入不同文件类型的工作薄的工作表

sdgyc

批量导入不同文件类型的工作薄的工作表.zip (265.2 KB, 下载次数: 14)

2018-8-19 10:25 上传

点击文件名下载附件
附件

请求老师帮忙：商品资料文件夹存放有多个xls、xlsx类型的工作薄，批量导入xls、xlsx类型的工作薄的Sheet1表$A1:U65536到本表。

abc123281

代码仅供测试参考


批量导入不同文件类型的工作薄的工作表123 sql.rar (233.8 KB, 下载次数: 9)

2018-8-19 11:26 上传

点击文件名下载附件

lsc900707

Sub test()
    Dim brr(1 To 100000, 1 To 21)
    p = ThisWorkbook.Path & "\商品资料\"
    f = Dir(p & "*.xls*")
    Application.ScreenUpdating = False
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set sht = Workbooks.Open(p & f).Sheets(1)
            Arr = sht.[A1].CurrentRegion
            Workbooks(f).Close False
            For i = 2 To UBound(Arr)
                m = m + 1
                For j = 1 To 21
                    brr(m, j) = Arr(i, j)
                Next
            Next
        End If
        f = Dir
    Loop
    Set sht = Nothing
    [a2].Resize(m, 21) = brr
    Application.ScreenUpdating = True
    MsgBox "OK！"
End Sub

lsc900707

参考附件：

sdgyc

lsc900707 发表于 2018-8-19 11:49
参考附件：

非常感谢！！

任飘渺

Sub sds()
    Dim cn As Object, rs As Object, sql As String, strPath As String
    Dim strFile As String, arr() As String
    Set cn = CreateObject("adodb.connection")
    strPath = ThisWorkbook.Path & "\商品资料\"
    strFile = Dir(strPath)
    Do While Len(strFile) > 0
        n = n + 1
        ReDim Preserve arr(1 To n) As String
        arr(n) = "select * from [" & strPath & strFile & "].[sheet1$]"
        strFile = Dir
    Loop
    sql = Join(arr, " union all ")
        With cn
            If Application.Version < 12 Then
                .provider = "microsoft.jet.oledb.8.0;extended properties=excel 8.0"
                .Open strPath & strFile
            Else
                .provider = "microsoft.ace.oledb.12.0;extended properties=excel 12.0"
                .Open ThisWorkbook.FullName
            End If
        End With
        Set rs = cn.Execute(sql)
        Range("a2:x65536").Clear
        Sheet1.Range("A2").CopyFromRecordset rs
        cn.Close
        Set cn = Nothing
        Set rs = Nothing
End Sub