遍历word文档出现死循环

Yorphone

在遍历文档时出现死循环，我的文件夹里面有60个word的docx文档，
不知道能不能加一下跳出的机制，

麻烦各位大神啦，
非常感谢，先行谢过~

1. Sub a()
   
2.     Dim doc As Document, myFile As String
   
3.     Dim a As Range
   
4.    
   
5.     myFile = Dir("D:" & "*.docx")
   
6.    
   
7.     Do While myFile <> ""
   
8.         myFile = "D:" & myFile
   
9.         Set doc = Documents.Open(myFile)
   
10.         Set a = doc.Range
    
11. 
    
12. 
    
13.         Selection.WholeStory
    
14.         '展开域
    
15.         Selection.Fields.ToggleShowCodes
    
16.         '≥≤ 把大换小，把小换小
    
17.         a.Find.Execute FindText:="≤", MatchWildcards:=True, replacewith:="$", Replace:=wdReplaceAll
    
18.         a.Find.Execute FindText:="≥", MatchWildcards:=True, replacewith:="#", Replace:=wdReplaceAll
    
19.         a.Find.Execute FindText:="$", MatchWildcards:=True, replacewith:="≥", Replace:=wdReplaceAll
    
20.         a.Find.Execute FindText:="#", MatchWildcards:=True, replacewith:="≤", Replace:=wdReplaceAll
    
21.         Selection.WholeStory
    
22.         Selection.Fields.ToggleShowCodes
    
23.         
    
24.         '保存退出
    
25.         doc.Save
    
26.         doc.Close
    
27.         
    
28.         Set doc = Nothing
    
29.         
    
30.         '查找下一个
    
31.         myFile = Dir
    
32.     Loop
    
33. End Sub

复制代码

Yorphone

希望大神们能指点指点~

3190496160

楼主是需要批量替换吗？这种贴子，以前回过贴的，搜搜看

Yorphone

3190496160 发表于 2020-5-28 12:07
楼主是需要批量替换吗？这种贴子，以前回过贴的，搜搜看

不是的，我是写了很长一段自动排版论文的代码，现在是要自动打开那60个文档，并应用、保存和关闭~

413191246se

请楼主参考：

1. Sub DIR_循环遍历文件夹()
   
2. 
   
3.     On Error Resume Next
   
4. 
   
5.     Dim objShell As Object, objFolder As Object, SearchPath$, DicList As Object, FileList As Object, Key, NowDic$, NowFile$, i&, FileName, FilePath, doc As Document, x&
   
6. 
   
7.     Set objShell = CreateObject("Shell.Application")
   
8.     Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹！", 0, 0)
   
9. 
   
10.     SearchPath = objFolder.self.Path & ""
    
11. 
    
12.     Set objShell = Nothing
    
13.     Set objFolder = Nothing
    
14. 
    
15.     If MsgBox("请确认！是否处理文件夹 " & SearchPath & " ?", 4 + 16) = vbNo Then Exit Sub
    
16. 
    
17.     Set DicList = CreateObject("Scripting.Dictionary")
    
18.     Set FileList = CreateObject("Scripting.Dictionary")
    
19. 
    
20.     DicList.Add SearchPath, ""
    
21. 
    
22.     i = 0
    
23.     Do While i < DicList.Count
    
24.         Key = DicList.keys
    
25.         NowDic = Dir(Key(i), vbDirectory)
    
26.         Do While NowDic <> ""
    
27.             If (NowDic <> ".") And (NowDic <> "..") Then
    
28.                 If (GetAttr(Key(i) & NowDic) And vbDirectory) = vbDirectory Then DicList.Add Key(i) & NowDic & "", ""
    
29.             End If
    
30.             NowDic = Dir()
    
31.         Loop
    
32.         i = i + 1
    
33.     Loop
    
34. 
    
35.     For Each Key In DicList.keys
    
36.         NowFile = Dir(Key)
    
37.         Do While NowFile <> ""
    
38.             FileList.Add NowFile, Key
    
39.             NowFile = Dir()
    
40.         Loop
    
41.     Next
    
42. 
    
43.     i = 0
    
44.     FileName = FileList.keys
    
45.     FilePath = FileList.Items
    
46.     Do While i < FileList.Count
    
47.         If FilePath(i) & FileName(i) Like "*.doc*" Then
    
48.             Set doc = Documents.Open(FileName:=FilePath(i) & FileName(i), Visible:=False)
    
49.             doc.Content.Font.Color = wdColorRed '单个文档处理
    
50.             doc.Close savechanges:=wdSaveChanges
    
51.             x = x + 1
    
52.         End If
    
53.         i = i + 1
    
54.     Loop
    
55. 
    
56.     Set DicList = Nothing
    
57.     Set FileList = Nothing
    
58. 
    
59.     MsgBox "文件夹包含 " & i & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
    
60. End Sub
    
61. Sub FSO_循环遍历文件夹()
    
62. 
    
63.     On Error Resume Next
    
64. 
    
65.     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&
    
66. 
    
67.     Set objShell = CreateObject("Shell.Application")
    
68.     Set objFolder = objShell.BrowseForFolder(0, "请选择文件夹！", 0, 0)
    
69. 
    
70.     pPath = objFolder.self.Path & ""
    
71. 
    
72.     Set objShell = Nothing
    
73.     Set objFolder = Nothing
    
74. 
    
75.     If MsgBox("请确认！是否处理文件夹 " & pPath & " ?", 4 + 16) = vbNo Then Exit Sub
    
76. 
    
77.     Set fso = CreateObject("Scripting.FileSystemObject")
    
78. 
    
79.     top = 1
    
80.     ReDim Stack(0 To top)
    
81. 
    
82.     Do While top >= 1
    
83.         For Each f In fso.GetFolder(pPath).Files
    
84.             n = n + 1
    
85.             stxt = f.Path
    
86.             If stxt Like "*.doc*" Then
    
87.                 Set doc = Documents.Open(FileName:=stxt, Visible:=False)
    
88.                 doc.Content.Font.Color = wdColorRed '单个文档处理
    
89.                 doc.Close savechanges:=wdSaveChanges
    
90.                 x = x + 1
    
91.             End If
    
92.         Next
    
93.         For Each fd In fso.GetFolder(pPath).SubFolders
    
94.             Stack(top) = fd.Path
    
95.             top = top + 1
    
96.             If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
    
97.         Next
    
98.         If top > 0 Then pPath = Stack(top - 1): top = top - 1
    
99.     Loop
    
100. 
     
101.     Set f = Nothing
     
102.     Set fd = Nothing
     
103.     Set fso = Nothing
     
104. 
     
105.     MsgBox "文件夹包含 " & n & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
     
106. End Sub

复制代码

413191246se

* 楼主，在处理论文前建议将文档打包检测并备份，以免排版不满意而误保存受损。