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

zhaogang1960

JJMY 发表于 2016-1-25 19:02
zhaogang1960 版主你好！
这个太实用了。
能用普通的代码完成这个效果吗

可以，即对这“1万多个”工作簿逐个打开取值，不过可以想象，即使我们什么也不做，仅逐个打开“1万多个”工作簿，大概需要1个小时或以上的时间，如果你不怕等待，我可以写这个“普通的代码”

JJMY

zhaogang1960 发表于 2016-1-25 19:52
可以，即对这“1万多个”工作簿逐个打开取值，不过可以想象，即使我们什么也不做，仅逐个打开“1万多个” ...

太谢谢zhaogang1960版主了！
我只有20多个工作簿，也是这样的。

zhaogang1960

JJMY 发表于 2016-1-26 18:27
太谢谢zhaogang1960版主了！
我只有20多个工作簿，也是这样的。

Sub 常规法()
    Dim Fso As Object, File As Object, m&, n&, arr, brr(1 To 100000, 0 To 3), i&, j&
    Application.ScreenUpdating = False
    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each File In Fso.GetFolder(CreateObject("scripting.filesystemobject").GetFolder(ThisWorkbook.Path).ParentFolder.Path & "\张庄乡八里村 旧表").Files
        If File.Name Like "*.xls*" Then
            n = n + 1
            With GetObject(File)
                arr = .Sheets("信息总表").Range("B2:D13")
                .Close 0
            End With
            brr(m + 1, 0) = n
            For i = 1 To UBound(arr)
                If Len(arr(i, 1)) = 0 Then Exit For
                m = m + 1
                For j = 1 To UBound(arr, 2)
                    brr(m, j) = arr(i, j)
                Next
            Next
        End If
    Next
    ActiveSheet.UsedRange.Offset(2).ClearContents
    Range("A3").Resize(m, 4) = brr
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

zhaogang1960

下面附件有20个工作簿，常规法速度下降不少，请测试：
新建文件夹.rar (335.21 KB, 下载次数: 896)

2016-1-26 18:42 上传

点击文件名下载附件

JJMY

zhaogang1960 发表于 2016-1-26 18:42
下面附件有20个工作簿，常规法速度下降不少，请测试：

谢谢zhaogang1960版主！
这个太好了！

214415363

你好，请问能不能帮帮忙，这个帖子里的解决方法，是限定路径和文件夹位置关系的，能不能有个代码是a列提取当前文件夹内所有的表名，b列为每张表里sheet1中I10的数值，这样的功能呢

214415363

我想把当前文件夹下的表名以及sheet1（表名为：台区基础档案）里的i10数据提取出来，表名放在a列，i10的数据放在b列。谢谢啦

214415363

不胜感激，希望大大能帮帮我，

lfx28

请问大侠这个能用在2007的文件里吗，用于*.xlsx

lfx28

有那样大侠帮忙解释一下这段代码吗，万分感谢
Sub Macro1()
    Dim cnn As Object, SQL$, p$, f$, m&, n&, t$
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(1).ClearContents
    Set cnn = CreateObject("ADODB.Connection")
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            n = n + 1
            If n = 1 Then
                cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & p & f
            Else
                t = "[Excel 8.0;hdr=no;Database=" & p & f & "]."
            End If
            m = m + 1
            If m > 49 Then
                Range("a65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                m = 1
                SQL = ""
            End If
            If Len(SQL) Then SQL = SQL & " union all "
            SQL = SQL & "select '" & Replace(f, ".xls", "") & "',* from " & t & "[材料汇总$G2:G2]"
        End If
        f = Dir()
    Loop
    If Len(SQL) Then Range("a65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
End Sub