请教：VBA跨工作薄动态取数

pppeeerrr

indirect 函数最大的问题就是被引用的工作薄必需在打开状态下，才能正确取数；

搜索网上资料后，好像函数是无法做到的，只有用VBA才能解决以上问题

我的需求是：如何在被引用文件不打开（或者貌似不打开）的情况下，取得所需数据？
ps：最好是用VBA取得数据以后，自动放到对应的工作表里

以上需求，请各位大侠帮帮手了，在此先谢谢了！！！

详见附件↓

pppeeerrr

这个是附件

qy1219no2

文件中居然看到了我的老家在里面，所以，就给你多做了一点。

打开文件时，根据提示启用宏
只需设置好要提取数据所在的工作表名称后，点击“提取数据”，完了，可以对汇总结果进行修改、统计，然后点击“另存为”按钮，即可将汇总结果保存为一个单独的EXCEL文件（不含代码的文件）
注意：不要修改“各类列表”工作表的表名称！！

zhaogang1960

ADO法请参考:

1. Sub 宏1()
   
2.     Dim cnn As Object, SQL$, arr, i&
   
3.     arr = Sheets("各类列表").[a1].CurrentRegion
   
4.     MyPath = ThisWorkbook.Path & ""
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     cnn.Open "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source =" & MyPath & arr(1, 3)
   
7.     For i = 1 To UBound(arr)
   
8.         SQL = "select * from [Excel 12.0;Database=" & MyPath & arr(i, 3) & ";].[" & arr(2, 2) & "$]"
   
9.         With Sheets(arr(i, 6))
   
10.             .Cells.ClearContents
    
11.             .[a1:b1] = Array("日期", "数值")
    
12.             .[a2].CopyFromRecordset cnn.Execute(SQL)
    
13.         End With
    
14.     Next
    
15.     cnn.Close
    
16.     Set cnn = Nothing
    
17. End Sub
    

复制代码

zhaogang1960

改进一下,仅需要提供引用的工作表名——2月

1. Sub 宏1()
   
2.     Dim cnn As Object, SQL$, sh As Worksheet, 工作表名$, m%
   
3.     工作表名 = "[" & Sheets("各类列表").[b2] & "$]"
   
4.     MyPath = ThisWorkbook.Path & ""
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     For Each sh In Worksheets
   
7.         If sh.Name <> "各类列表" Then
   
8.             With sh
   
9.                 If m = 0 Then
   
10.                     cnn.Open "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source =" & MyPath & .Name & ".xlsx"
    
11.                     m = 1
    
12.                 End If
    
13.                 .Cells.ClearContents
    
14.                 .[a1:b1] = Array("日期", "数值")
    
15.                 SQL = "select * from [Excel 12.0;Database=" & MyPath & .Name & ".xlsx;]." & 工作表名
    
16.                 .[a2].CopyFromRecordset cnn.Execute(SQL)
    
17.             End With
    
18.         End If
    
19.     Next
    
20.     cnn.Close
    
21.     Set cnn = Nothing
    
22. End Sub

复制代码

zhaogang1960

请测试附件
VBA跨工作薄动态取数.rar (66.62 KB, 下载次数: 127)

2014-5-28 16:52 上传

点击文件名下载附件

pppeeerrr

qy1219no2 发表于 2014-5-28 16:23
文件中居然看到了我的老家在里面，所以，就给你多做了一点。

打开文件时，根据提示启用宏

感谢 qy1219no2！
看你在文中提到了老家，看来是老乡了哈，谢谢这么快给到回复，我测试了一下，本例能够得到我需要的结果；
虽然基本不懂vba，但还是要仔细看看你写的代码，如有不清楚的地方，还要劳烦你哈

pppeeerrr

zhaogang1960 发表于 2014-5-28 16:52
请测试附件

没想到惊动了版主，还是超级版主，感谢 zhaogang1960
测试完全能够达到需求，我会仔细看看代码的，还是想要把这个代码弄成模版，来完成类似的工作；
再次感谢！

pppeeerrr

赵老师，仔细测试您的附件以后，有些疑惑，详见附件！

zhaogang1960

pppeeerrr 发表于 2014-5-29 14:38
赵老师，仔细测试您的附件以后，有些疑惑，详见附件！

1. Sub 宏1()
   
2.     Dim cnn As Object, SQL$, arr, i&
   
3.     Dim objWMI As Object
   
4.     Const HKEY_LOCAL_MACHINE = &H80000002
   
5.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
6.     objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 200
   
7.     arr = Sheets("各类列表").[a1].CurrentRegion
   
8.     MyPath = ThisWorkbook.Path & ""
   
9.     Set cnn = CreateObject("adodb.connection")
   
10.     cnn.Open "Provider = Microsoft.Ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source =" & MyPath & arr(1, 3)
    
11.     For i = 1 To UBound(arr)
    
12.         SQL = "select * from [Excel 12.0;imex=1;Database=" & MyPath & arr(i, 3) & ";].[" & arr(2, 2) & "$]"
    
13.         With Sheets(arr(i, 6))
    
14.             .Cells.ClearContents
    
15.             .[a1:b1] = Array("日期", "数值")
    
16.             .[a2].CopyFromRecordset cnn.Execute(SQL)
    
17.             With .UsedRange
    
18.                 .Value = .Value
    
19.             End With
    
20.         End With
    
21.     Next
    
22.     cnn.Close
    
23.     Set cnn = Nothing
    
24. End Sub
    

复制代码