从2548个excel表中提取数据到同一张excel表中

妙音怀古

我有2548多个excel表，文件名从1.xlsx---2548.xlsx，每个表里含报告和数据两个sheet，需要从每个表里提取数据放到同一个表里方便统计分析，我和我同事人工打开每个excel，手工复制粘贴，效率很低很低，从网上找帖子，写了公式，比如：='C:\Users\lixiu\Desktop\puren result\puren result\[1.xlsx]报告'!$D$6，用于提取样本编号，能实现1个表的自动填充，但是不能拖拽公式把【1.xlsx】序列填充为【2548.xlsx】。
报公式里的[1.xlsx]改成[A2.xlsx]或者改成["&$A2&".xlsx]都不行.....

xiangbaoan

简单，要附件……

xiangbaoan

Sub test() '木有附件，仅是猜测
Dim cn As Object, rs As Object, p$, f$, sq$, ar(1 To 5000, 0), n&
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        n = n + 1
        sq = "SELECT * FROM [Excel 12.0;HDR=NO;Database=" & p & f & "].[报告$D6:D6]"
        rs.Open sq, cn, 1, 3
        ar(n, 0) = rs(0)
        If rs.State = 1 Then rs.Close
    End If
    f = Dir
Loop
[c1].Resize(n) = ar
cn.Close
Set cn = Nothing
Set rs = Nothing
End Sub