VBA 循环遍历文件夹（宏）通用代码 2019-6-10

413191246se · 发表于 2019-6-10 19:56

* 各位朋友：下面给出两种《循环遍历文件夹及子文件夹》VBA 宏的通用代码，效能一样，测试结果正确！

* 但请在使用这两个宏之前备份要处理的文件，以免造成损失。

* 请注意：宏中有一行代码，注释为“单个文档处理”，只须替换这句代码即可，不用打开/关闭/保存，并且文档默认是打开后不显示的（如果非要显示，请将 visible:=False 改为 visible:=True 或删除即可，但效率低）。

* 第一个宏——原作者：kiddragon，本人略修改

Sub 循环遍历文件夹_Dir()
On Error Resume Next
Dim objShell As Object, objFolder As Object, SearchPath$, DicList As Object, FileList As Object, Key, NowDic$, NowFile$, i&, FileName, FilePath, doc As Document, x&
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹！", 0, 0)
SearchPath = objFolder.self.Path & ""
Set objShell = Nothing
Set objFolder = Nothing
If MsgBox("请确认！是否处理文件夹 " & SearchPath & " ?", 4 + 16) = vbNo Then Exit Sub
Set DicList = CreateObject("Scripting.Dictionary")
Set FileList = CreateObject("Scripting.Dictionary")
DicList.Add SearchPath, ""
i = 0
Do While i < DicList.Count
Key = DicList.keys
NowDic = Dir(Key(i), vbDirectory)
Do While NowDic <> ""
If (NowDic <> ".") And (NowDic <> "..") Then
If (GetAttr(Key(i) & NowDic) And vbDirectory) = vbDirectory Then DicList.Add Key(i) & NowDic & "", ""
End If
NowDic = Dir()
Loop
i = i + 1
Loop
For Each Key In DicList.keys
NowFile = Dir(Key)
Do While NowFile <> ""
FileList.Add NowFile, Key
NowFile = Dir()
Loop
Next
i = 0
FileName = FileList.keys
FilePath = FileList.Items
Do While i < FileList.Count
If FilePath(i) & FileName(i) Like "*.doc*" Then
Set doc = Documents.Open(FileName:=FilePath(i) & FileName(i), Visible:=False)
doc.Content.Font.Color = wdColorRed '单个文档处理
doc.Close SaveChanges:=wdSaveChanges
x = x + 1
End If
i = i + 1
Loop
Set DicList = Nothing
Set FileList = Nothing
MsgBox "文件夹包含 " & i & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
End Sub

复制代码

* 第二个宏——原作者：duquancai，本人略修改

Sub 循环遍历文件夹_FSO()
On Error Resume Next
Dim objShell As Object, objFolder As Object, pPath$, f As Object, fd As Object, fso As Object, Stack$(), top&, n&, stxt$, doc As Document, x&
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹！", 0, 0)
pPath = objFolder.self.Path & ""
Set objShell = Nothing
Set objFolder = Nothing
If MsgBox("请确认！是否处理文件夹 " & pPath & " ?", 4 + 16) = vbNo Then Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
top = 1
ReDim Stack(0 To top)
Do While top >= 1
For Each f In fso.GetFolder(pPath).Files
n = n + 1
stxt = f.Path
If stxt Like "*.doc*" Then
Set doc = Documents.Open(FileName:=stxt, Visible:=False)
doc.Content.Font.Color = wdColorRed '单个文档处理
doc.Close SaveChanges:=wdSaveChanges
x = x + 1
End If
Next
For Each fd In fso.GetFolder(pPath).SubFolders
Stack(top) = fd.Path
top = top + 1
If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
Next
If top > 0 Then pPath = Stack(top - 1): top = top - 1
Loop
Set f = Nothing
Set fd = Nothing
Set fso = Nothing
MsgBox "文件夹包含 " & n & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
End Sub

复制代码

duquancai · 发表于 2019-6-10 20:50

有兴趣测试一下以下代码（文档越多好，子文件越多越深越好，便于测试！！！）看看你说的“dir+双字典”快还是不快？？？？

Sub main()
Dim DirFile$, workStack$(), top&
top = 1: ReDim workStack(top)
pPath$ = "D:\test\" '初始文件夹
Do While top >= 1
      DirFile = Dir(pPath & "*.doc*") '文件名后缀设定
      Do While DirFile <> ""
         t = pPath & DirFile

'          处理文件...................

         DirFile = Dir
      Loop
      DirFile = Dir(pPath, vbDirectory)
      Do While DirFile <> ""
         If DirFile <> "." And DirFile <> ".." Then
            If (GetAttr(pPath & DirFile) And vbDirectory) = vbDirectory Then
                  workStack(top) = pPath & DirFile & "\"
                  top = top + 1
                  ReDim Preserve workStack(top)
            End If
         End If
         DirFile = Dir
      Loop
      pPath = workStack(top - 1): top = top - 1
Loop
Erase workStack
End Sub

daibao88 · 发表于 2019-6-10 20:56

学习了，谢谢！

413191246se · 发表于 2019-6-11 01:12

杜先生/老师：2 楼代码经测试，实不如前两个。但处理结果正确！
.
昨天我就发现，当 DIR 函数在查询时，最好不要写形如 dir("E:\LoopDir" & "*.docx") 的文件类型。先探测出有多少个文件和文件夹，然后循环给出文件名，在对文件名做判断（if 文件名 like"*.docx"then），这样会快一点。
.
实测时间如下，取首次为准：
DIR:5.047’/16.484’（昨晚）
FSO:5.062’/17.937’（昨晚）
本次:6.84’/20.702’（今晚）
.
多谢杜先生/老师费心！辛苦了！——我现在要找一找 Word2007 可否用代码来做工具栏，并且将一些内置命令按钮和宏按钮置于其上。

changhong8 · 发表于 2019-6-11 07:51

不如用shell cmd dir 命令快些，尤其是在多层级多文件的情况下

duquancai · 发表于 2019-6-11 08:44

413191246se 发表于 2019-6-11 01:12
杜先生/老师：2 楼代码经测试，实不如前两个。但处理结果正确！
.
昨天我就发现，当 DIR 函数在查询时， ...

算了，跟你争辩毫无意义。

413191246se · 发表于 2019-6-11 09:03

* 杜先生/老师，您是大师，我是小学生，什么也不懂的，请不必与我计较。
* 昨晚测试，是在家里，当然前两个宏也是在家里的慢电脑上测试的，单位的电脑相应快一些，我并未测试。
我是在录制宏的基础上一步一步地进步起来的，来论坛 8 年半了，其实水平还是很低。
* 还是祝杜先生/老师注意身体健康，时常给我们指导与批评；但我们水平太低，杜老师也不必期望太高。
* 5 楼朋友说的，本人不会，但是谢谢了！

zpy2 · 发表于 2019-6-11 09:33

413191246se 发表于 2019-6-11 01:12
杜先生/老师：2 楼代码经测试，实不如前两个。但处理结果正确！
.
昨天我就发现，当 DIR 函数在查询时， ...

Sub 循环遍历文件夹_Dir()
这个是你测试的吗？咋感觉没有深度递归。。。

413191246se · 发表于 2019-6-11 10:01

楼上朋友，你好！谢谢参与测试。我测试了一个含有 25 个文件的文件夹及子文件夹，子文件夹有 3 级，没有问题！没有太深的目录测试。好吧，我准备来一个 10 级子目录的测试。请你也帮助我测试上面 1 楼两个宏，谢谢！

wdpfox · 发表于 2019-6-11 14:59

413191246se 老师的钻研精神可嘉，学习者就需要这种精神，加油！

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

[分享] VBA 循环遍历文件夹（宏）通用代码 2019-6-10