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

zhaogang1960

张雄友 发表于 2014-12-15 19:13
这种查找很实用，有时根本不知在哪里出现过，很方便查找。

1. 
   
2. Sub ADO加字典()
   
3.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$
   
4.     Dim d As Object, a, arr, brr$(), i&, fn$, ma%
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Mypath = ThisWorkbook.Path & "\我的文件夹"
   
7.     MyFile = Dir(Mypath & "*.xlsx")
   
8.     Do While MyFile <> ""
   
9.         Set cnn = CreateObject("adodb.connection")
   
10.         cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & Mypath & MyFile
    
11.         Set rs = cnn.OpenSchema(20)
    
12.         fn = Replace(MyFile, ".xlsx", "")
    
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.                     SQL = "select f1 from [" & s & "] where f1 is not null"
    
18.                     Set rst = cnn.Execute(SQL)
    
19.                     If Not rst.EOF Then
    
20.                         arr = rst.GetRows
    
21.                         For i = 0 To UBound(arr, 2)
    
22.                             If Not d.Exists(arr(0, i)) Then d(arr(0, i)) = fn Else d(arr(0, i)) = d(arr(0, i)) & "," & fn
    
23.                         Next
    
24.                     End If
    
25.                 End If
    
26.             End If
    
27.             rs.MoveNext
    
28.         Loop
    
29.         MyFile = Dir()
    
30.     Loop
    
31.     arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    
32.     ReDim brr(1 To UBound(arr), 10000)
    
33.     For i = 1 To UBound(arr)
    
34.         s = d(arr(i, 1))
    
35.         If InStr(s, ",") Then
    
36.             a = Split(s, ",")
    
37.             For j = 0 To UBound(a)
    
38.                 brr(i, j) = a(j)
    
39.             Next
    
40.             If j > ma Then ma = j
    
41.         Else
    
42.             brr(i, 0) = s
    
43.         End If
    
44.     Next
    
45.     [a1].CurrentRegion.Offset(1, 1).Clear
    
46.     [b2].Resize(i - 1, ma + 1) = brr
    
47.     rs.Close
    
48.     rst.Close
    
49.     Set rs = Nothing
    
50.     Set rst = Nothing
    
51.     cnn.Close
    
52.     Set cnn = Nothing
    
53. End Sub
    

复制代码

zhaogang1960

没有美化格式，请看附件
help.rar (41.08 KB, 下载次数: 45)

2014-12-15 19:26 上传

点击文件名下载附件

ashengz86

zhaogang1960 发表于 2014-12-15 19:25

老师，如果再精确到工作表的名字呢？并且支持多个表查询，比如sheet1和sheet2和sheet3里都有可以查到的信息，B列显示文件名，C列D列之后依次显示所在的sheet表名（sheet1，sheet2，sheet3），这个是不是有点太难了？

ashengz86

zhaogang1960 发表于 2014-12-15 18:58
多个工作簿吧？如果是用逗号隔开：

还有个问题 如果是在“我的文件夹”下有多个文件夹，在这些文件夹中查找的话，  这个路径该怎么改？

zhaogang1960

ashengz86 发表于 2014-12-16 09:42
还有个问题 如果是在“我的文件夹”下有多个文件夹，在这些文件夹中查找的话，  这个路径该怎么改？

请模拟效果、上传附件说明具体要求

ashengz86

zhaogang1960 发表于 2014-12-16 12:17
请模拟效果、上传附件说明具体要求

老师，首先万分感谢！请见附件

我现在想实现多文件夹多 多工作表sheet查找，并显示sheet名！

zhaogang1960

ashengz86 发表于 2014-12-16 14:26
老师，首先万分感谢！请见附件我现在想实现多文件夹多 多工作表sheet查找，并显示sheet名！

输出太复杂了，改为文件名:表名：

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$, 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.                         For i = 0 To UBound(arr, 2)
    
23.                             If Not d.Exists(arr(0, i)) Then d(arr(0, i)) = fn & ":" & Replace(s, "$", "") Else d(arr(0, i)) = d(arr(0, i)) & "," & fn & ":" & Replace(s, "$", "")
    
24.                         Next
    
25.                     End If
    
26.                 End If
    
27.             End If
    
28.             rs.MoveNext
    
29.         Loop
    
30.     Next
    
31.     arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    
32.     ReDim brr(1 To UBound(arr), 10000)
    
33.     For i = 1 To UBound(arr)
    
34.         s = d(arr(i, 1))
    
35.         If InStr(s, ",") Then
    
36.             a = Split(s, ",")
    
37.             For j = 0 To UBound(a)
    
38.                 brr(i, j) = a(j)
    
39.             Next
    
40.             If j > ma Then ma = j
    
41.         Else
    
42.             brr(i, 0) = s
    
43.         End If
    
44.     Next
    
45.     [a1].CurrentRegion.Offset(1, 1).ClearContents
    
46.     [b2].Resize(i - 1, ma + 1) = brr
    
47.     rs.Close
    
48.     rst.Close
    
49.     Set rs = Nothing
    
50.     Set rst = Nothing
    
51.     cnn.Close
    
52.     Set cnn = Nothing
    
53. End Sub
    
54. 
    
55. Sub GetFiles(ByVal Folder As Object, ByRef arrf$(), ByRef mf&)
    
56.     Dim SubFolder As Object
    
57.     Dim File As Object
    
58.     If Folder.Path <> ThisWorkbook.Path Then
    
59.         For Each File In Folder.Files
    
60.             If File.Name Like "*.xlsx" Then
    
61.                 mf = mf + 1
    
62.                 ReDim Preserve arrf(1 To 2, 1 To mf)
    
63.                 arrf(1, mf) = File
    
64.                 arrf(2, mf) = "'" & Replace(File.Name, ".xlsx", "")
    
65.             End If
    
66.         Next
    
67.     End If
    
68.     For Each SubFolder In Folder.SubFolders
    
69.         Call GetFiles(SubFolder, arrf, mf)
    
70.     Next
    
71. End Sub
    
72. 
    

复制代码

zhaogang1960

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

2014-12-16 19:54 上传

点击文件名下载附件

张雄友

zhaogang1960 发表于 2014-12-15 19:25

对于在同一工作簿中的不同工作表出现过的，只要一次就可以了。

zhaogang1960

张雄友 发表于 2014-12-17 22:33
对于在同一工作簿中的不同工作表出现过的，只要一次就可以了。

1. Sub ADO加字典()
   
2.     On Error Resume Next
   
3.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$
   
4.     Dim d As Object, a, arr, brr$(), i&, fn$, ma%
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.     .InitialFileName = ThisWorkbook.Path & ""
   
8.     If .Show = False Then Exit Sub
   
9.     Mypath = .SelectedItems(1) & ""
   
10.     End With
    
11.     MyFile = Dir(Mypath & "*.xlsx")
    
12.     Do While MyFile <> ""
    
13.         Set cnn = CreateObject("adodb.connection")
    
14.         cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & Mypath & MyFile
    
15.         Set rs = cnn.OpenSchema(20)
    
16.         fn = Replace(MyFile, ".xlsx", "")
    
17.         Do Until rs.EOF
    
18.             If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
19.                 s = Replace(rs("TABLE_NAME").Value, "'", "")
    
20.                 If Right(s, 1) = "$" Then
    
21.                     SQL = "select f1 from [" & s & "] where f1 is not null"
    
22.                     Set rst = cnn.Execute(SQL)
    
23.                     If Not rst.EOF Then
    
24.                         arr = rst.GetRows
    
25.                         For i = 0 To UBound(arr, 2)
    
26.                             If Not d.Exists(arr(0, i)) Then
    
27.                                 d(arr(0, i)) = fn
    
28.                             Else
    
29.                                 If InStr("," & d(arr(0, i)) & ",", "," & fn & ",") = 0 Then d(arr(0, i)) = d(arr(0, i)) & "," & fn
    
30.                             End If
    
31.                         Next
    
32.                     End If
    
33.                 End If
    
34.             End If
    
35.             rs.MoveNext
    
36.         Loop
    
37.         MyFile = Dir()
    
38.     Loop
    
39.     arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    
40.     ReDim brr(1 To UBound(arr), 10000)
    
41.     For i = 1 To UBound(arr)
    
42.         s = d(arr(i, 1))
    
43.         If InStr(s, ",") Then
    
44.             a = Split(s, ",")
    
45.             For j = 0 To UBound(a)
    
46.                 brr(i, j) = a(j)
    
47.             Next
    
48.             If j > ma Then ma = j
    
49.         Else
    
50.             brr(i, 0) = s
    
51.         End If
    
52.     Next
    
53.     [a1].CurrentRegion.Offset(1, 1).Clear
    
54.     [b2].Resize(i - 1, ma + 1) = brr
    
55.     rs.Close
    
56.     rst.Close
    
57.     Set rs = Nothing
    
58.     Set rst = Nothing
    
59.     cnn.Close
    
60.     Set cnn = Nothing
    
61. End Sub
    

复制代码