【VBA】【增强版】【收藏备用】遍历文件夹内所有文件模块V5

2018-12-03 12:34:30

• 

• 平淡如茶

  

  码龄6年

N次修改了，此模块应该比较健壮吧，特点：

1、可遍历目录下所有文件

2、可筛选文件类型，可限定文件名关键词

3、遍历目录（文件夹）允许存在小数点.

4、一步到位，不用编写2次循环（即先遍历出目录，再遍历文件）

1. Sub searchFile()
2. ' ---------------遍历文件夹内所有文件-----------------------------
3. FileType = '.txt' '查找文件类型
4. FileKeyword = 'svr' '进一步限定文件范围，当然也可以继续添加限定条件
5. '对话框方式选择路径
6. Dim fd As FileDialog
7. Set fd = Application.FileDialog(msoFileDialogFolderPicker)
8. If fd.Show = -1 Then
9. sFolderPath = fd.SelectedItems(1)
10. Set fd = Nothing
11. Else
12. Set fd = Nothing
13. Exit Sub
14. End If
15. Dim file() As String, retFile() As String, fullPath$
16. Dim i%, k%, t%, f$
17. i = 1: k = 1: t = 1
18. ReDim file(1 To i)
19. file(1) = sFolderPath & '\'
20. '相对而言i父目录，k为对应子目录
21. Do Until i > k
22. Debug.Print 'file(' & i & ')=' & file(i)
23. f = Dir(file(i), vbDirectory)
24. Do Until f = ''
25. Debug.Print 'f1=' & f
26. If InStr(f, FileType) > 0 And InStr(f, FileKeyword) > 0 Then
27. ReDim Preserve retFile(1 To t)
28. ' 把遍历得到的文件存放到retFile(t)中
29. retFile(t) = file(i) & f
30. t = t + 1
31. ElseIf f <> '.' And f <> '..' Then
32. fullPath = file(i) & f & '\'
33. If FileFolderExists(fullPath) Then
34. k = k + 1
35. ReDim Preserve file(1 To k)
36. file(k) = fullPath
37. End If
38. End If
39. f = Dir
40. Loop
41. i = i + 1
42. Loop
43. End Sub
44. Function FileFolderExists(strFullPath As String) As Boolean
45. Dim fso
46. Set fso = CreateObject('Scripting.FileSystemObject')
47. If fso.folderExists(strFullPath) Then FileFolderExists = True
48. Set fso = Nothing
49. End Function