求高手帮忙写段代码，要求批量跨文件引用一个工作簿的个别特定单元格

315297781

RT,一直困扰我的问题，在线等高手帮忙，不胜感激

315297781

自己顶一下，F5已经按烂啦{:soso_e143:}

zhaogang1960

请测试：

1. Sub Macro1()
   
2.     Dim Fso As Object, sFileType$, i&, j&, m&, n&, na$, brr(), arrf$(), mf&
   
3.     Dim cnn As Object, rs As Object, SQL$, s$
   
4.     Application.ScreenUpdating = False
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     sFileType = "*.xlsx"
   
7.     Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
   
8.     ReDim brr(1 To mf, 1 To 2)
   
9.     For i = 1 To mf
   
10.         Set cnn = CreateObject("adodb.connection")
    
11.         cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='excel 12.0;hdr=no';Data Source=" & arrf(i)
    
12.         Set rs = cnn.OpenSchema(20) 'adSchemaTables
    
13.         Do Until rs.EOF
    
14.             If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
15.                 s = Replace(rs("TABLE_NAME").Value, "'", "")
    
16.                 If Right(s, 1) = "$" Then
    
17.                     brr(i, 1) = Replace(Mid(arrf(i), InStrRev(arrf(i), "") + 1), "销售日报.xlsx", "")
    
18.                     SQL = "select * from [" & s & "c6:c6]"
    
19.                     brr(i, 2) = cnn.Execute(SQL)(0)
    
20.                     Exit Do
    
21.                 End If
    
22.             End If
    
23.             rs.MoveNext
    
24.         Loop
    
25.     Next
    
26.     [a1].CurrentRegion.Offset(1).ClearContents
    
27.     [a2].Resize(i - 1, 2) = brr
    
28.     Set Fso = Nothing
    
29.     rs.Close
    
30.     Set rs = Nothing
    
31.     cnn.Close
    
32.     Set cnn = Nothing
    
33.     Application.ScreenUpdating = True
    
34. End Sub
    
35. 
    
36. Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
    
37.     Dim Folder As Object
    
38.     Dim SubFolder As Object
    
39.     Dim File As Object
    
40.     Set Folder = Fso.GetFolder(sPath)
    
41.     If sPath <> ThisWorkbook.Path Then
    
42.         For Each File In Folder.Files
    
43.             If File.Name Like sFileType Then
    
44.                 mf = mf + 1
    
45.                 ReDim Preserve arrf(1 To mf)
    
46.                 arrf(mf) = File
    
47.             End If
    
48.         Next
    
49.     End If
    
50.     If Folder.SubFolders.Count > 0 Then
    
51.         For Each SubFolder In Folder.SubFolders
    
52.             Call GetFiles(SubFolder.Path, sFileType, Fso, arrf, mf)
    
53.         Next
    
54.     End If
    
55.     Set Folder = Nothing
    
56.     Set File = Nothing
    
57.     Set SubFolder = Nothing
    
58. End Sub
    

复制代码

zhaogang1960

请看附件
求助.rar (111.38 KB, 下载次数: 32)

2013-12-19 16:12 上传

点击文件名下载附件

315297781

zhaogang1960 发表于 2013-12-19 16:13
请看附件

非常感谢，我试试看

315297781

zhaogang1960 发表于 2013-12-19 16:13
请看附件

非常感谢，不过还有点问题，我把全年的日报都复制到这个文件夹下边之后，再执行就会出现有些数据不太正确，好几天的数据都一样，还有只出现了1月至4月的数据，后边的都没有，麻烦您了

zhaogang1960

315297781 发表于 2013-12-19 16:36
非常感谢，不过还有点问题，我把全年的日报都复制到这个文件夹下边之后，再执行就会出现有些数据不太正确 ...

请检查你要取得的数据是不是C6单元格，如果不是，请说明它们应该在哪里

315297781

zhaogang1960 发表于 2013-12-19 16:42
请检查你要取得的数据是不是C6单元格，如果不是，请说明它们应该在哪里

所有的表格都是c6单元格，刚才大部分的都看了一下，特别是出现错误的那几个

zhaogang1960

315297781 发表于 2013-12-19 16:45
所有的表格都是c6单元格，刚才大部分的都看了一下，特别是出现错误的那几个

请上传出错的那几个工作簿分析一下

315297781

zhaogang1960 发表于 2013-12-19 16:47
请上传出错的那几个工作簿分析一下

看出来了，是我自己的错，真的不好意思了，麻烦你了