[已解决]如何遍历子文件夹模糊查找文件夹名

lyf7276 · 发表于 2013-4-18 12:55

本帖最后由爱疯于 2013-4-19 12:33 编辑

比如我D盘有个"学习资料""的文件夹,"学习资料"文件夹里面有:VBA视频大全,VBA常用代码集合,EXCEL资料,WORD视频8_30集合等文件夹,我如何根据"VBA视频37集"的前五个字符查找到VBA视频大全这个文件夹名,再返回给一指定值,我好根据这个指定值打开这个文件的工作簿?

最佳答案

月排行榜 / 总排行榜

香川群子

2013-4-18 14:34

FileSystemObject方法查找文件的代码：
利用递归算法搜寻子文件夹，找到含指定字符s的文件后打开。

Dim s$, fNm$
Sub FindFile()
s = InputBox("Input key word:", "Find Files") '输入关键词
If s = "" Then Exit Sub
pth = InputBox("Confirm FileFolder Path:", "Find Files", ThisWorkbook.Path) '输入指定文件夹
Call FindFileName(pth) '递归搜寻子文件夹
Workbooks.Open Filename:=fNm '打开搜寻到的文件
'这里写你自己的后续处理代码，或调用其它过程
'…………
End Sub
Sub FindFileName(pth) '递归搜寻代码
If fNm <> "" Then Exit Sub '找到后退出递归
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(pth)
Set fsb = fld.SubFolders
For Each fd In fsb '遍历该文件夹的所有子文件夹
For Each f In fd.Files '遍历每个子文件夹中的所有文件
If InStr(f.Name, s) Then '用instr方法比对文件名称是否包含指定字符
fNm = fd.Path & "" & f.Name
Exit Sub '找到后退出递归
End If
Next
Call FindFileName(fd.Path) '本文件夹检查完毕后，继续深层搜素其子文件夹
Next
End Sub

复制代码

代码试过了没有问题，但未作容错处理。(楼主根据需要自己添加代码吧)
比如，找到了含指定字符的文件，但不是Excel文件，
而是Word文件或其它格式的文件因而无法在Excel中打开。

…………
另外，找到第一个符合要求的文件后就退出了……
如果需要找到全部，那么所有Exit Sub语句就应该要注释掉……并做适当处理。

呵呵。

跳转到最佳答案楼层

hwc2ycy · 发表于 2013-4-18 13:41

有许多工作薄，每个工作薄中 ...
http://www.excelpx.com/thread-299155-1-1.html

代码改下就可以了。

lyf7276 · 发表于 2013-4-18 13:51

谢谢老班,我先下载了再慢慢啃去

lyf7276 · 发表于 2013-4-18 13:56

老班,看代码要密码呀

香川群子 · 发表于 2013-4-18 14:10

呵呵，楼主你说的好像过于复杂，兜圈子了吧。

整理一下楼主的目的：
在指定文件夹的未知子文件中，找到并打开含字符"VBA视频37集"的Excel文件。

lyf7276 · 发表于 2013-4-18 14:16

不是五楼那个意思,比如说根据你的名字"""香川群子"找到"""香川的电话"这个文件夹,(是文件夹不是工作簿),请指教.

香川群子 · 发表于 2013-4-18 14:34

FileSystemObject方法查找文件的代码：
利用递归算法搜寻子文件夹，找到含指定字符s的文件后打开。

Dim s$, fNm$
Sub FindFile()
s = InputBox("Input key word:", "Find Files") '输入关键词
If s = "" Then Exit Sub
pth = InputBox("Confirm FileFolder Path:", "Find Files", ThisWorkbook.Path) '输入指定文件夹
Call FindFileName(pth) '递归搜寻子文件夹
Workbooks.Open Filename:=fNm '打开搜寻到的文件
'这里写你自己的后续处理代码，或调用其它过程
'…………
End Sub
Sub FindFileName(pth) '递归搜寻代码
If fNm <> "" Then Exit Sub '找到后退出递归
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(pth)
Set fsb = fld.SubFolders
For Each fd In fsb '遍历该文件夹的所有子文件夹
For Each f In fd.Files '遍历每个子文件夹中的所有文件
If InStr(f.Name, s) Then '用instr方法比对文件名称是否包含指定字符
fNm = fd.Path & "" & f.Name
Exit Sub '找到后退出递归
End If
Next
Call FindFileName(fd.Path) '本文件夹检查完毕后，继续深层搜素其子文件夹
Next
End Sub

复制代码

代码试过了没有问题，但未作容错处理。(楼主根据需要自己添加代码吧)
比如，找到了含指定字符的文件，但不是Excel文件，
而是Word文件或其它格式的文件因而无法在Excel中打开。

…………
另外，找到第一个符合要求的文件后就退出了……
如果需要找到全部，那么所有Exit Sub语句就应该要注释掉……并做适当处理。

呵呵。

lyf7276 · 发表于 2013-4-18 14:44

谢谢香川群子，我先用下试试

香川群子 · 发表于 2013-4-18 15:16

本帖最后由香川群子于 2013-4-18 15:19 编辑

hwc2ycy 发表于 2013-4-18 13:41
有许多工作薄，每个工作薄中 ...
http://www.excelpx.com/thread-299155-1-1.html

修改了你的Dir代码：

Dim s$, fNm$, cnt&
Sub test()
s = InputBox("Input key word:", "Find Files", s)
If s = "" Then Exit Sub
pth = InputBox("Confirm FileFolder Path:", "Find Files", ThisWorkbook.Path)
fNm = "": cnt = 0: tms = Timer
Call ListDirs(pth)
MsgBox Format(Timer - tms, "0.000s ") & cnt & vbCr & fNm
' Workbooks.Open filename:=fNm
End Sub
Sub ListDirs(ByVal Path As String)
Dim i&, j&, arrPath(), sPath$, fName$
i = 1: j = 1
ReDim arrPath(1 To 1)
arrPath(i) = Path & ""
On Error Resume Next
sPath = arrPath(j)
Do While Len(sPath)
cnt = cnt + 1
fName = Dir(sPath & "*.*", vbDirectory + vbNormal)
Do While fName <> ""
If (fName = "." Or fName = "..") Then GoTo Nxt
If (GetAttr(sPath & "" & fName) And vbDirectory) = 16 Then
If Err.Number Then Err.Clear: GoTo Nxt
i = i + 1: ReDim Preserve arrPath(1 To i)
arrPath(i) = sPath & fName & ""
Else
If InStr(fName, s) Then fNm = sPath & fName: Exit Sub
End If
Nxt:
fName = Dir
cnt = cnt + 1
Loop
j = j + 1: If j > i Then Exit Do
sPath = arrPath(j)
Loop
End Sub

复制代码

代码稍显复杂，不过Dir的效率比较高，运算速度快。

看、灰机 · 发表于 2015-4-27 17:44

香川群子发表于 2013-4-18 15:16
修改了你的Dir代码：代码稍显复杂，不过Dir的效率比较高，运算速度快。

香川老师，如果有多个匹配的档案，能否全部显示出来，然后根据自己的需要选择双击打开？谢谢指教！

		自动登录	找回密码
密码			注册

[已解决]如何遍历子文件夹模糊查找文件夹名

评分