向前辈们求一个“查找文档中不成对的符号标为红色”的宏

kqbt

如果想更改为“设定文字颜色为红色”的标注方式，其实稍微修改一下代码中“突出显示为鲜绿色”那一句即可，如果对代码不是太熟悉，可以通过录制宏的方式来了解，这样不仅能节约你等待答案的时间，同时在学习方面还可能会有所收获，当然了态度是关键。

下面的代码修改为标注为红色字体，并显示标注个数：

1. '======注意======3版
   
2. '1 跨段落匹配不视为成对
   
3. '2 同标点多层嵌套匹配不视为成对
   
4. '3 未测试表格中的标点
   
5. '================
   
6. Sub 标注不成对标点符号()
   
7.   Dim Arr(), i As Integer, m As Integer, n As Integer, o As Integer, t As Long
   
8.   Dim wRng As Range, rRng As Range, sRng As Range, tRng As Range
   
9.   'ActiveDocument.Content.HighlightColorIndex = wdAuto
   
10.   'ActiveDocument.Content.Font.Color = wdColorRed
    
11.   Application.ScreenUpdating = False
    
12.   Arr = Array(-24146, -24145, -24144, -24143, -24142, -24141, -24140, -24139, -24138, _
    
13.               -24137, -24136, -24135, -24134, -24133, -24132, -24131, -24130, -24129, _
    
14.               -23640, -23639, -23620, -23618, -23589, -23587, -23557, -23555, _
    
15.               40, 41, 60, 62, 91, 93, 123, 125)
    
16.   t = 0
    
17.   For i = 0 To UBound(Arr)
    
18.     Selection.HomeKey wdStory
    
19.     Set wRng = Selection.Range
    
20.     m = 1: n = 0: o = i Mod 2
    
21.     If o = 0 Then
    
22. line1:
    
23.       wRng.MoveUntil Chr(Arr(i))
    
24.       Set rRng = ActiveDocument.Range(wRng.End, wRng.End + 1).Duplicate
    
25.       If rRng = Chr(Arr(i)) Then
    
26.         wRng.MoveUntil Chr(Arr(i + m))
    
27.         Set sRng = ActiveDocument.Range(wRng.End, wRng.End + 1).Duplicate
    
28.         If sRng = Chr(Arr(i + m)) Then
    
29.           Set tRng = ActiveDocument.Range(rRng.End, sRng.End)
    
30.           If InStr(tRng, Chr(Arr(i + n))) Or tRng.Paragraphs.Count > 1 Then
    
31.             'rRng.HighlightColorIndex = wdBrightGreen
    
32.             rRng.Font.Color = wdColorRed
    
33.             wRng.SetRange rRng.Start, rRng.End
    
34.             t = t + 1
    
35.           End If
    
36.           GoTo line1
    
37.         Else
    
38.           'rRng.HighlightColorIndex = wdBrightGreen
    
39.           rRng.Font.Color = wdColorRed
    
40.           wRng.SetRange rRng.Start, rRng.End
    
41.           t = t + 1
    
42.           GoTo line1
    
43.         End If
    
44.       End If
    
45.     Else
    
46.       m = m - 1: n = n - 1
    
47.       Set rRng = wRng.Duplicate
    
48. line2:
    
49.       wRng.MoveUntil Chr(Arr(i + m))
    
50.       Set sRng = ActiveDocument.Range(wRng.End, wRng.End + 1).Duplicate
    
51.       If sRng = Chr(Arr(i + m)) Then
    
52.         Set tRng = ActiveDocument.Range(rRng.End, sRng.End)
    
53.         If tRng.Paragraphs.Count > 1 Then
    
54.           tRng.SetRange wRng.Paragraphs(1).Range.Start, tRng.End
    
55.         End If
    
56.         If InStr(tRng, Chr(Arr(i + n))) = 0 Or InStr(tRng, Chr(13)) Then
    
57.           'sRng.HighlightColorIndex = wdBrightGreen
    
58.           sRng.Font.Color = wdColorRed
    
59.           t = t + 1
    
60.         End If
    
61.         wRng.SetRange sRng.Start, sRng.End
    
62.         Set rRng = wRng.Duplicate
    
63.         GoTo line2
    
64.       End If
    
65.     End If
    
66.   Next
    
67.   Set wRng = ActiveDocument.Content
    
68.   With wRng.Find
    
69.     .ClearFormatting
    
70.     .Replacement.ClearFormatting
    
71.     Do While .Execute("^13[0-9一二三四五六七八九十百]@[/)）]", , , True, , , True)
    
72.       'wRng.HighlightColorIndex = wdAuto
    
73.       wRng.Font.Color = wdColorAutomatic
    
74.       wRng.SetRange wRng.End, ActiveDocument.Content.End
    
75.       t = t - 1
    
76.     Loop
    
77.   End With
    
78.   Application.ScreenUpdating = True
    
79.   MsgBox "共标注了 " & t + 1 & " 个不成对标点！"
    
80. End Sub

复制代码

13907933959

kqbt 发表于 2015-11-10 19:49
如果想更改为“设定文字颜色为红色”的标注方式，其实稍微修改一下代码中“突出显示为鲜绿色”那一句即可， ...

版主前辈好！
非常感谢您！我是一个读完中医毕业不久，今年上半年才拜一位中医师傅再学徒，免为其难的为师傅整理他，差不多积累了一生的资料及有关书籍，本人对电脑又是个外行，在论坛上有幸碰到413191246se 前辈，是他教会了我怎样使用宏，因我现处在学徒阶段事也比较多，要背要记的东西也太多，再一个原来对电脑也接触得极少，最主要还是脑瓜子比较笨，所以短时期内也很难学会难度这样大的技巧，没有办法只能是碰到问题就向前辈求助！借前辈的力来尽快完成这个事，还望前辈们多多见谅。
版主前辈、这个宏以相当的好用，如您有时间，能不能再加一个循环遍历文件夹的，因我现在有很多的文件要处理。谢谢您！

kqbt

13907933959 发表于 2015-11-11 08:51
版主前辈好！
非常感谢您！我是一个读完中医毕业不久，今年上半年才拜一位中医师傅再学徒，免为其难的为 ...

2003版本下试一下吧，做好备份，我自己未进行测试：

1. Sub 标注不成对标点符号()
   
2.   Dim iPath As String, j As Long
   
3.     With Application.FileDialog(msoFileDialogFolderPicker)
   
4.     If .Show Then
   
5.       iPath = .SelectedItems(1)
   
6.     End If
   
7.   End With
   
8.   If iPath = "False" Then Exit Sub
   
9.   With Application.FileSearch
   
10.     .NewSearch
    
11.     .LookIn = iPath
    
12.     .SearchSubFolders = False
    
13.     .FileName = "*.doc"
    
14.     If .Execute() > 0 Then
    
15.       For j = 1 To .FoundFiles.Count
    
16.         iPath = .FoundFiles(j)
    
17.         ERR_BD (iPath)
    
18.       Next
    
19.     End If
    
20.   End With
    
21.   MsgBox "标注完成！"
    
22. End Sub
    
23. '======注意======3版
    
24. '1 跨段落匹配不视为成对
    
25. '2 同标点多层嵌套匹配不视为成对
    
26. '3 未测试表格中的标点
    
27. '================
    
28. Function ERR_BD(iPath As String)
    
29.   Dim Arr(), i As Integer, m As Integer, n As Integer, o As Integer, t As Long
    
30.   Dim wDoc As Document, wRng As Range, rRng As Range, sRng As Range, tRng As Range
    
31.   'ActiveDocument.Content.HighlightColorIndex = wdAuto
    
32.   'ActiveDocument.Content.Font.Color = wdColorRed</p><p>  Application.ScreenUpdating = False
    
33.   Arr = Array(-24146, -24145, -24144, -24143, -24142, -24141, -24140, -24139, -24138, _
    
34.               -24137, -24136, -24135, -24134, -24133, -24132, -24131, -24130, -24129, _
    
35.               -23640, -23639, -23620, -23618, -23589, -23587, -23557, -23555, _
    
36.               40, 41, 60, 62, 91, 93, 123, 125)
    
37.   t = 0
    
38.   Set wDoc = Documents.Open(iPath)
    
39.   wDoc.Activate
    
40.   For i = 0 To UBound(Arr)
    
41.     Selection.HomeKey wdStory
    
42.     Set wRng = Selection.Range
    
43.     m = 1: n = 0: o = i Mod 2
    
44.     If o = 0 Then
    
45. line1:
    
46.       wRng.MoveUntil Chr(Arr(i))
    
47.       Set rRng = ActiveDocument.Range(wRng.End, wRng.End + 1).Duplicate
    
48.       If rRng = Chr(Arr(i)) Then
    
49.         wRng.MoveUntil Chr(Arr(i + m))
    
50.         Set sRng = ActiveDocument.Range(wRng.End, wRng.End + 1).Duplicate
    
51.         If sRng = Chr(Arr(i + m)) Then
    
52.           Set tRng = ActiveDocument.Range(rRng.End, sRng.End)
    
53.           If InStr(tRng, Chr(Arr(i + n))) Or tRng.Paragraphs.Count > 1 Then
    
54.             'rRng.HighlightColorIndex = wdBrightGreen
    
55.             rRng.Font.Color = wdColorRed
    
56.             wRng.SetRange rRng.Start, rRng.End
    
57.             t = t + 1
    
58.           End If
    
59.           GoTo line1
    
60.         Else
    
61.           'rRng.HighlightColorIndex = wdBrightGreen
    
62.           rRng.Font.Color = wdColorRed
    
63.           wRng.SetRange rRng.Start, rRng.End
    
64.           t = t + 1
    
65.           GoTo line1
    
66.         End If
    
67.       End If
    
68.     Else
    
69.       m = m - 1: n = n - 1
    
70.       Set rRng = wRng.Duplicate
    
71. line2:
    
72.       wRng.MoveUntil Chr(Arr(i + m))
    
73.       Set sRng = ActiveDocument.Range(wRng.End, wRng.End + 1).Duplicate
    
74.       If sRng = Chr(Arr(i + m)) Then
    
75.         Set tRng = ActiveDocument.Range(rRng.End, sRng.End)
    
76.         If tRng.Paragraphs.Count > 1 Then
    
77.           tRng.SetRange wRng.Paragraphs(1).Range.Start, tRng.End
    
78.         End If
    
79.         If InStr(tRng, Chr(Arr(i + n))) = 0 Or InStr(tRng, Chr(13)) Then
    
80.           'sRng.HighlightColorIndex = wdBrightGreen
    
81.           sRng.Font.Color = wdColorRed
    
82.           t = t + 1
    
83.         End If
    
84.         wRng.SetRange sRng.Start, sRng.End
    
85.         Set rRng = wRng.Duplicate
    
86.         GoTo line2
    
87.       End If
    
88.     End If
    
89.   Next
    
90.   Set wRng = ActiveDocument.Content
    
91.   With wRng.Find
    
92.     .ClearFormatting
    
93.     .Replacement.ClearFormatting
    
94.     Do While .Execute("^13[0-9一二三四五六七八九十百]@[/)）]", , , True, , , True)
    
95.       'wRng.HighlightColorIndex = wdAuto
    
96.       wRng.Font.Color = wdColorAutomatic
    
97.       wRng.SetRange wRng.End, ActiveDocument.Content.End
    
98.       t = t - 1
    
99.     Loop
    
100.   End With
     
101.   wDoc.Close True
     
102.   Application.ScreenUpdating = True
     
103.   'MsgBox "共标注了 " & t + 1 & " 个不成对标点！"
     
104. End Function

复制代码

13907933959

kqbt 发表于 2015-11-12 22:31
2003版本下试一下吧，做好备份，我自己未进行测试：

版主前辈好！
下知怎么会事，代码运行不了，最末尾一句End Function</p>变为了红色，烦劳您再看一下。

kqbt

13907933959 发表于 2015-11-13 07:10
版主前辈好！
下知怎么会事，代码运行不了，最末尾一句End Function变为了红色，烦劳您再看一下。

那个</P>是多余的。

13907933959

kqbt 发表于 2015-11-13 08:46
那个是多余的。

版主前辈好！
现在可以了，运行正常。感谢版主前辈为我节省了很多的时间！

13907933959

13907933959 发表于 2015-11-13 09:49
版主前辈好！
现在可以了，运行正常。感谢版主前辈为我节省了很多的时间

错误，删除。

13907933959

kqbt 发表于 2015-11-12 22:31
2003版本下试一下吧，做好备份，我自己未进行测试：

版主前辈好！
今天用该宏处理文件，发现只能对文件夹里面的文件上面不成对的标点符号标注，但子文件夹……子文件夹里面的文件上面不成对的标点符号都不能被标注。劳请版主前辈换一个能处理文件夹里面所有的子文件夹……循环遍历的宏。谢谢！

kqbt

13907933959 发表于 2015-11-17 07:47
版主前辈好！
今天用该宏处理文件，发现只能对文件夹里面的文件上面不成对的标点符号标注，但子文件夹… ...

把

1. .SearchSubFolders = False

复制代码

改为

1. .SearchSubFolders = True

复制代码

13907933959

kqbt 发表于 2015-11-17 08:28
把
改为

版主前辈好！
换好了，谢谢您！