批量提取一个文件下的多个工作簿指定的单元格内容到新表

hiton

批量提取一个文件夹下多个不同名字工作簿信息总表中的B2-D13到新表中的BCD列。求大神支招呀，这有1万多个需要转，我要累死呀。

chenhu1981

你新表还有好多工作表，你想放到哪个？

zhaogang1960

结果放在一张表上，请参考：
Sub ADO法()
    Dim Fso As Object, File As Object, cnn As Object, SQL$, m&, n&, arr, brr(1 To 100000, -1 To 2), i&, j&
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("adodb.connection")
    For Each File In Fso.GetFolder(CreateObject("scripting.filesystemobject").GetFolder(ThisWorkbook.Path).ParentFolder.Path & "\张庄乡八里村 旧表").Files
        If File.Name Like "*.xls*" Then
            n = n + 1
            If n = 1 Then
                cnn.Open "provider=microsoft.Ace.oledb.12.0;extended properties=excel 12.0;data source=" & File
                SQL = "select * from [信息总表$b2:d13]"
            Else
                SQL = "select * from [Excel 12.0;Database=" & File & ";].[信息总表$b2:d13]"
            End If
            arr = cnn.Execute(SQL).GetRows
            brr(m + 1, -1) = n
            For i = 0 To UBound(arr, 2)
                If IsNull(arr(0, i)) Then Exit For
                m = m + 1
                For j = 0 To 2
                    brr(m, j) = arr(j, i)
                Next
            Next
        End If
    Next
    ActiveSheet.UsedRange.Offset(2).ClearContents
    Range("A3").Resize(m, 4) = brr
    cnn.Close
    Set cnn = Nothing
    Set File = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

hiton

新表只有一个
旧表非常多

hiton

能帮忙吗？

zhaogang1960

请测试附件
新建文件夹.rar (498.15 KB, 下载次数: 1831)

2016-1-25 17:11 上传

点击文件名下载附件

hiton

放到第一个就行，放完我可以再复制到其他地方去

hiton

太谢谢你了，谢谢

hiton

运行错误3706是啥意思

JJMY

zhaogang1960 发表于 2016-1-25 17:11
请测试附件

zhaogang1960 版主你好！
这个太实用了。
能用普通的代码完成这个效果吗
谢谢！