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

ashengz86

如附件
一个文件夹——文件夹里有三个文件
还有一个表《查找.xlsx》

文件夹里的三个表里各有各的内容
我想用《查找.xlsx》这个表，根据A列的内容，在“我的文件夹”里查找能匹配上A列单元格内容的文件名，《查找.xlsx》里的黄色区域就是能匹配上的表名，匹配不上为空即可！
并将文件夹的名字输出在B列

谢谢各位大侠拔刀相助！

zhaogang1960

如果每个工作簿工作表名都是Sheet1，且工作簿数量不超过49个，且A列名字仅会出现在一个工作簿中，请参考:

1. Sub ADO联合查询()
   
2.     Dim MyFile$, SQL$
   
3.     Mypath = ThisWorkbook.Path & "\我的文件夹"
   
4.     MyFile = Dir(Mypath & "*.xlsx")
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName
   
7.     Do While Len(MyFile)
   
8.         If Len(SQL) Then SQL = SQL & " union all "
   
9.         SQL = SQL & "select '" & Replace(MyFile, ".xlsx", "") & "' as 表名,f1 from [Excel 12.0;hdr=no;Database=" & Mypath & MyFile & "].[Sheet1$]"
   
10.        MyFile = Dir
    
11.     Loop
    
12.     SQL = "select b.表名 from [Sheet1$] a left join (" & SQL & ") b on a.名字=b.f1"
    
13.     [b2].CopyFromRecordset cnn.Execute(SQL)
    
14.     cnn.Close
    
15.     Set cnn = Nothing
    
16. End Sub
    

复制代码

zhaogang1960

ADO法没有传统意义的Open工作簿，查询多个工作簿时速度较快
请测试附件
help.rar (35 KB, 下载次数: 135)

2014-12-15 16:16 上传

点击文件名下载附件

ashengz86

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

老师 工作薄肯定超过49 我就是想在非常多的文件中 直接输出相应的文件名 要不然就只能一个一个找然后去贴了~

zhaogang1960

ashengz86 发表于 2014-12-15 16:42
老师 工作薄肯定超过49 我就是想在非常多的文件中 直接输出相应的文件名 要不然就只能一个一个找然后去贴 ...

下面ADO加字典法不需要所有限制条件，请参考：

1. Sub ADO加字典()
   
2.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$
   
3.     Dim d As Object, arr, brr$(), i&, fn$
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Mypath = ThisWorkbook.Path & "\我的文件夹"
   
6.     MyFile = Dir(Mypath & "*.xlsx")
   
7.     Do While MyFile <> ""
   
8.         Set cnn = CreateObject("adodb.connection")
   
9.         cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & Mypath & MyFile
   
10.         Set rs = cnn.OpenSchema(20)
    
11.         fn = Replace(MyFile, ".xlsx", "")
    
12.         Do Until rs.EOF
    
13.             If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
14.                 s = Replace(rs("TABLE_NAME").Value, "'", "")
    
15.                 If Right(s, 1) = "[        DISCUZ_CODE_0        ]quot; Then
    
16.                     SQL = "select f1 from [" & s & "] where f1 is not null"
    
17.                     Set rst = cnn.Execute(SQL)
    
18.                     If Not rst.EOF Then
    
19.                         arr = rst.GetRows
    
20.                         For i = 0 To UBound(arr, 2)
    
21.                             d(arr(0, i)) = fn
    
22.                         Next
    
23.                     End If
    
24.                 End If
    
25.             End If
    
26.             rs.MoveNext
    
27.         Loop
    
28.         MyFile = Dir()
    
29.     Loop
    
30.     arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    
31.     ReDim brr(1 To UBound(arr), 1 To 1)
    
32.     For i = 1 To UBound(arr)
    
33.         brr(i, 1) = d(arr(i, 1))
    
34.     Next
    
35.     [b2].Resize(i - 1) = brr
    
36.     rs.Close
    
37.     rst.Close
    
38.     Set rs = Nothing
    
39.     Set rst = Nothing
    
40.     cnn.Close
    
41.     Set cnn = Nothing
    
42. End Sub
    

复制代码

zhaogang1960

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

2014-12-15 16:57 上传

点击文件名下载附件

张雄友

如果A列内容在多个工作表出现过怎么办？

zhaogang1960

张雄友 发表于 2014-12-15 18:39
如果A列内容在多个工作表出现过怎么办？

多个工作簿吧？如果是用逗号隔开：

1. Sub ADO加字典()
   
2.     Dim cnn As Object, rs As Object, rst As Object, SQL$, Mypath$, MyFile$, s$
   
3.     Dim d As Object, arr, brr$(), i&, fn$
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Mypath = ThisWorkbook.Path & "\我的文件夹"
   
6.     MyFile = Dir(Mypath & "*.xlsx")
   
7.     Do While MyFile <> ""
   
8.         Set cnn = CreateObject("adodb.connection")
   
9.         cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & Mypath & MyFile
   
10.         Set rs = cnn.OpenSchema(20)
    
11.         fn = Replace(MyFile, ".xlsx", "")
    
12.         Do Until rs.EOF
    
13.             If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
14.                 s = Replace(rs("TABLE_NAME").Value, "'", "")
    
15.                 If Right(s, 1) = "$" Then
    
16.                     SQL = "select f1 from [" & s & "] where f1 is not null"
    
17.                     Set rst = cnn.Execute(SQL)
    
18.                     If Not rst.EOF Then
    
19.                         arr = rst.GetRows
    
20.                         For i = 0 To UBound(arr, 2)
    
21.                             If Not d.Exists(arr(0, i)) Then d(arr(0, i)) = fn Else d(arr(0, i)) = d(arr(0, i)) & "," & fn
    
22.                         Next
    
23.                     End If
    
24.                 End If
    
25.             End If
    
26.             rs.MoveNext
    
27.         Loop
    
28.         MyFile = Dir()
    
29.     Loop
    
30.     arr = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    
31.     ReDim brr(1 To UBound(arr), 1 To 1)
    
32.     For i = 1 To UBound(arr)
    
33.         brr(i, 1) = d(arr(i, 1))
    
34.     Next
    
35.     [b2].Resize(i - 1) = brr
    
36.     rs.Close
    
37.     rst.Close
    
38.     Set rs = Nothing
    
39.     Set rst = Nothing
    
40.     cnn.Close
    
41.     Set cnn = Nothing
    
42. End Sub
    

复制代码

zhaogang1960

程序本来就测试所有工作表，只是仅对有数据的进行处理
请测试效果
help.rar (36.85 KB, 下载次数: 95)

2014-12-15 18:59 上传

点击文件名下载附件

张雄友

zhaogang1960 发表于 2014-12-15 19:00
程序本来就测试所有工作表，只是仅对有数据的进行处理
请测试效果

这种查找很实用，有时根本不知在哪里出现过，很方便查找。