|
本帖最后由 Nhand 于 2018-6-15 13:30 编辑
我想通过一段代码实现文件夹及子文件夹下所有xls文档的遍历,以搜索出包含特定内容的所有xls文档的路径。这段代码在小范围内测试是准确的,比如我一个文件夹下面放2个子文件夹,然后7,8层子文件夹下再放xls文档,能得出正确结果,但是如果我随意搜索一个包含大量文件的文件夹,都会得到一个统一的结果:自动打开了一个xlsm文档,名称为示例144 检查电脑名称。xlsm(只读)下面提示 对不起,您不是合法用户,文件将关闭! 请问这是怎么回事?
Sub sousuo()
path = ThisWorkbook.FullName
aa = 0
inp1 = Application.InputBox("功能选择 1 :只要查找到数据就退出程序 2:查找出所有出现数据的文档(耗时长) ")
inp = Application.InputBox("请输入要查找的内容,点击确定后选择一个要搜索的文件夹")
'''''''查找所有xls文档
Set ob = CreateObject("Shell.Application")
Set obf = ob.BrowseForFolder(0, "选择文件夹", 0, 0)
If Not obf Is Nothing Then lj = obf.self.path & "\"
Set obf = Nothing
Set ob = Nothing
Set d = CreateObject("Scripting.dictionary") '创建一个字典对象
Set dd = CreateObject("Scripting.dictionary") '存放所有xls文档路径
d.Add (lj), ""
i = 0
Do While i < d.Count
keyy = d.keys '开始遍历字典
nm = Dir(keyy(i), vbDirectory) '查找目录
Do While nm <> ""
If nm <> "." And nm <> ".." Then
If (GetAttr(keyy(i) & nm) And vbDirectory) = vbDirectory Then '如果是次级目录
d.Add (keyy(i) & nm & "\"), "" '就往字典中添加这个次级目录名作为一个条目
End If
End If
nm = Dir '继续遍历寻找
Loop
i = i + 1
Loop
For Each keyy In d.keys
nm = Dir(keyy & "*.xls")
Do While nm <> ""
dd.Add (Keyy & nm), ""
nm = Dir
Loop
Next
''''''''''''''''''查找所有xls文档结束
Set d1 = CreateObject("scripting.dictionary")
For Each t In dd.keys
If t <> path Then
Workbooks.Open t, 0
For Each y In ActiveWorkbook.Worksheets
Set r = y.UsedRange.Find(inp)
If Not r Is Nothing Then
d1(t) = ""
aa = aa + 1
If inp1 = 1 Then
ActiveWorkbook.Close False
GoTo 1
End If
End If
Next
ActiveWorkbook.Close False
End If
Next
1 If aa = 0 Then
MsgBox "没有查找到相关内容"
Else
Workbooks.Add
ActiveWorkbook.ActiveSheet.Cells(1, 1) = "以下是查找到数据的文件路径"
a = 2
For Each m In d1.keys
ActiveWorkbook.ActiveSheet.Cells(a, 1) = m
a = a + 1
Next
End If
End Sub
|
|