根据A列单元格内容查找文件并将文件名放在B列

zhaogang1960

请测试附件
查找.rar (49.18 KB, 下载次数: 47)

2014-12-17 22:41 上传

点击文件名下载附件

张雄友

zhaogang1960 发表于 2014-12-17 22:41

一下子还没摸索出来。

zhaogang1960

张雄友 发表于 2014-12-17 22:52
一下子还没摸索出来。

1. Sub ADO加字典()
   
2.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$
   
3.     Dim d As Object, a, arr, brr$(), i&, fn$, fnws$, ma%
   
4.     Dim Fso As Object, Folder As Object, arrf$(), mf&
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set Folder = Fso.GetFolder(ThisWorkbook.Path)
   
7.     Call GetFiles(Folder, arrf, mf)
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     For l = 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(1, l)
    
12.         Set rs = cnn.OpenSchema(20)
    
13.         fn = arrf(2, l)
    
14.         Do Until rs.EOF
    
15.             If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
16.                 s = Replace(rs("TABLE_NAME").Value, "'", "")
    
17.                 If Right(s, 1) = "$" Then
    
18.                     SQL = "select f1 from [" & s & "] where f1 is not null"
    
19.                     Set rst = cnn.Execute(SQL)
    
20.                     If Not rst.EOF Then
    
21.                         arr = rst.GetRows
    
22.                         fnws = fn & ":" & Replace(s, "$", "")
    
23.                         For i = 0 To UBound(arr, 2)
    
24.                             If Not d.Exists(arr(0, i)) Then
    
25.                                 d(arr(0, i)) = fnws
    
26.                             Else
    
27.                                 If InStr("," & d(arr(0, i)) & ",", "," & fnws & ",") = 0 Then d(arr(0, i)) = d(arr(0, i)) & "," & fnws
    
28.                             End If
    
29.                         Next
    
30.                     End If
    
31.                 End If
    
32.             End If
    
33.             rs.MoveNext
    
34.         Loop
    
35.     Next
    
36.     arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    
37.     ReDim brr(1 To UBound(arr), 10000)
    
38.     For i = 1 To UBound(arr)
    
39.         s = d(arr(i, 1))
    
40.         If InStr(s, ",") Then
    
41.             a = Split(s, ",")
    
42.             For j = 0 To UBound(a)
    
43.                 brr(i, j) = a(j)
    
44.             Next
    
45.             If j > ma Then ma = j
    
46.         Else
    
47.             brr(i, 0) = s
    
48.         End If
    
49.     Next
    
50.     [a1].CurrentRegion.Offset(1, 1).ClearContents
    
51.     [b2].Resize(i - 1, ma + 1) = brr
    
52.     rs.Close
    
53.     rst.Close
    
54.     Set rs = Nothing
    
55.     Set rst = Nothing
    
56.     cnn.Close
    
57.     Set cnn = Nothing
    
58.     Set Folder = Nothing
    
59.     Set Fso = Nothing
    
60. End Sub
    
61. 
    
62. Sub GetFiles(ByVal Folder As Object, ByRef arrf$(), ByRef mf&)
    
63.     Dim SubFolder As Object
    
64.     Dim File As Object
    
65.     If Folder.Path <> ThisWorkbook.Path Then
    
66.         For Each File In Folder.Files
    
67.             If File.Name Like "*.xls*" Then
    
68.                 mf = mf + 1
    
69.                 ReDim Preserve arrf(1 To 2, 1 To mf)
    
70.                 arrf(1, mf) = File
    
71.                 arrf(2, mf) = "'" & Replace(File.Name, ".xlsx", "")
    
72.             End If
    
73.         Next
    
74.     End If
    
75.     For Each SubFolder In Folder.SubFolders
    
76.         Call GetFiles(SubFolder, arrf, mf)
    
77.     Next
    
78. End Sub
    
79. 
    

复制代码

zhaogang1960

请测试附件
help.rar (52.26 KB, 下载次数: 71)

2014-12-17 23:09 上传

点击文件名下载附件

ashengz86

zhaogang1960 发表于 2014-12-15 16:17
ADO法没有传统意义的Open工作簿，查询多个工作簿时速度较快
请测试附件

http://club.excelhome.net/thread-1173569-1-1.html   赵老师我又遇到了个新问题，如果您看到的话，请帮帮忙，真的真的很需要！谢谢！

leehery

追随您的步伐

leehery

赵刚老师在吗能不能帮各小忙。如附件
通过search工作薄指定单元格的关键字，提取并生成另外文件夹中的文件名并复制其中部分内容。
仰慕，感谢！

ashengz86

leehery 发表于 2016-8-4 16:00
赵刚老师在吗能不能帮各小忙。如附件
通过search工作薄指定单元格的关键字，提取并生成另外文件夹中的文件 ...

貌似已经不当版主了

sofebaby

这个案例我我遇见的难题有点相似！

LMY123

SQL多薄多表查询

补充内容 (2018-4-14 09:53):
ado+字典