查找缺失一边的单引号

413191246se

相见，一处一查一改一存，比较麻烦，不知你弟是不是仔细之人，不建议如此；改标点是小事，汲取知识是大事。

sylun

相见是缘8 发表于 2019-9-27 07:56
老师、辛苦了！
我按照你的提示‘运行代码前，先将文档中的半角后单引号全部替换为了全角后单引号’，再 ...

楼主原来的要求就是查到不合格的引号就标记并停止的。所以我想这不是优化的问题。我也觉得这样做也许较好修改，虽然慢了不少。如果要一起搜索不是不行，但思路就不一样了。当然，程序对有些特殊情形可能不一定适应，毕竟楼主所提供的文档标点不是一般的乱，似有故意而为之嫌

相见是缘8

413191246se 发表于 2019-9-27 21:05
相见，一处一查一改一存，比较麻烦，不知你弟是不是仔细之人，不建议如此；改标点是小事，汲取知识是大事。

老师好！
是啊！麻烦是麻烦，可没有更好的办法也只能如此！
我求助这个问题，一方面是为了帮我弟弟把这个文档修改好，减少他阅读理解的难度，增加他阅读的兴趣。另一方面是这类问题其实我也经常碰到，想得到解决此类问题的方法。

相见是缘8

sylun 发表于 2019-9-27 23:36
楼主原来的要求就是查到不合格的引号就标记并停止的。所以我想这不是优化的问题。我也觉得这样做也许较好 ...

老师好！
抱歉！抱歉！我昨天一下没反应过来，原来是运行你给的代码后，要修改好查找到单引号，再运行代码，再修改……如此循环操作，这和我想要的效果（查到不成对不合格的引号时，程序就让光标停在此处，并在前面加上一红色★，程序停止）也差不多，不同的是你把它们全部变为了“绿色突出显示”。

老师、这个“绿色突出显示”，醒目是醒目，但修改时间长了眼睛看久了也很不舒服，能不能劳你把“绿色突出显示”去掉，还是在它前面加上一红色★。

另外、我绝对不是“故意而为之”，真的是我学中医的弟弟发来的文档，让我帮忙修改，本来想人工查误修改，一是工作量太大。二是很容易遗漏（这个是最主要的原因）。三是这类问题我也经常碰到。就想用VBA解决，可本人水平未到，才特发帖向老师们求助的。

sylun

相见是缘8 发表于 2019-9-28 08:39
老师好！
抱歉！抱歉！我昨天一下没反应过来，原来是运行你给的代码后，要修改好查找到单引号，再运行代 ...

按楼主的新要求改写了代码，连续检查标记，处理速度一般，请测试。这次只标可疑引号（超过3000个），还是以不同颜色区分前后引号等异常情形，不增减任何字符，感觉比加星号方便直观，随时可以将格式恢复原样。要加上星号也简单，楼主可在相关代码中添加替换文本即可

1. Sub MarKingInvalidQM()
   
2.     '运行代码前请先将文档中的半角后单引号替换为全角后单引号，或将代码行中的ChrW(8217)改为chr(39)
   
3.     Dim myRange As Range
   
4.     Dim aRange As Range
   
5.     Dim mystart As Long
   
6.     Dim myend As Long
   
7.     Dim mylen As Long
   
8.     Dim i As Integer
   
9.    
   
10.     Application.ScreenUpdating = False
    
11. '    ActiveDocument.Range.Find.Execute findtext:=Chr(39), replacewith:=ChrW(8217), Replace:=wdReplaceAll
    
12.     Set myRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
    
13.     With myRange
    
14.         myend = .End
    
15.         Do
    
16.             mystart = .Start
    
17.             If .Text Like "*" & ChrW(8216) & "*" & "?*" & ChrW(8217) & "*" Then
    
18.                 With .Find
    
19.                     .MatchWildcards = True
    
20.                     .Text = ChrW(8216) & "[!" & ChrW(8217) & "]@" & ChrW(8217) '查找一个完整的引号对
    
21.                     If .Execute = True Then '找到匹配时
    
22.                         i = i + OddMarKing(.Parent.Duplicate, 1)
    
23.                         i = i + OddMarKing(ActiveDocument.Range(mystart, .Parent.Start + 1), 2)
    
24.                     Else
    
25.                         i = i + OddMarKing(.Parent, 3)
    
26.                         Exit Do
    
27.                     End If
    
28.                     .Parent.SetRange .Parent.End, myend
    
29.                 End With
    
30.             Else
    
31.                 i = i + OddMarKing(.Duplicate, 3)
    
32.                 Exit Do
    
33.             End If
    
34.         Loop
    
35.     End With
    
36.     MsgBox "查找完毕，" & IIf(i > 0, "共标记" & i & "处异常文本！", "未发现异常！")
    
37.     Application.ScreenUpdating = True
    
38. End Sub
    
39. 
    
40. Function OddMarKing(oRange As Range, r As Integer) As Integer
    
41.     Dim otext As String
    
42.     Options.DefaultHighlightColorIndex = IIf(r = 1, wdGreen, wdYellow)
    
43.     If r = 3 Then Options.DefaultHighlightColorIndex = wdPink
    
44.     With oRange.Find
    
45. '        .ClearFormatting
    
46.         .Replacement.Highlight = True
    
47.         If r = 1 Then
    
48.             .Parent.SetRange .Parent.Start + 1, .Parent.End - 1
    
49.             If Len(.Parent.Text) > 0 Then .Execute findtext:=ChrW(8216), Replace:=wdReplaceAll
    
50.         ElseIf r = 2 Then
    
51.             .Parent.End = .Parent.End - 1
    
52.             If Len(.Parent.Text) > 0 Then .Execute findtext:=ChrW(8217), Replace:=wdReplaceAll
    
53.         Else
    
54.             If Len(.Parent.Text) > 0 Then
    
55.                 .Execute findtext:=ChrW(8216), Replace:=wdReplaceAll
    
56.                 .Execute findtext:=ChrW(8217), Replace:=wdReplaceAll
    
57.             End If
    
58.         End If
    
59.         OddMarKing = UBound(Split(.Parent.Text, ChrW(8216))) + UBound(Split(.Parent.Text, ChrW(8217)))
    
60.     End With
    
61. End Function

复制代码

相见是缘8

sylun 发表于 2019-9-28 15:33
按楼主的新要求改写了代码，连续检查标记，处理速度一般，请测试。这次只标可疑引号（超过3000个），还是 ...

老师好！

感谢你！让你费心了！

测试了，速度还可以。这个突出显示绿色、黄色、粉红色，是各代表区分什么的？

发现有些误查的现象，如下图中红色框的是成对的单引号，红色箭头所指应为不成对的单引号。

sylun

相见是缘8 发表于 2019-9-28 19:30
老师好！感谢你！让你费心了！测试了，速度还可以。这个突出显示绿色、黄色、粉红色，是各代表区分什么的 ...

绿色用于标注有疑问的前单引号，黄色标注后单引号。粉色用于不成对的引号，主要出现在处理文本的首尾位置，或者文本只有不成对的引号时。
楼主看不懂代码吗？
我这里运行的结果与楼主所说的并不一样。不知什么原因。如第一个图（好像内容并非一样）

413191246se

sylun 老师 辛苦了！请注意休息。相见 也注意休息。

相见是缘8

sylun 发表于 2019-9-28 21:11
绿色用于标注有疑问的前单引号，黄色标注后单引号。粉色用于不成对的引号，主要出现在处理文本的首尾位置 ...

老师好！

奇怪了，刚才我又重新下载了“附件”，测试了 3 遍，结果和我昨天上传的图片一样。我的具体操作是：先用手动“查找\替换”，（查找'替换为’）勾选框内的“使用通配符”，替换了 5994 个，再运行你的代码，查找到 2909 处可疑文本，结果如下图：

老师、我来这个论坛也属于“机缘巧合”，这还要感谢 413191246se 老师和他的徒弟 13907933959 ，去年一次在“百度”上搜索一个“关键饲”，无意中看到他师徒两人的一段问答，才来到这个论坛。我只会一点手动的“查找\替换”，对 VBA 我还处在小白阶段，无中文注释的代码基本看不懂，希望多多得到你和各位老师的指教和帮助！谢谢！

相见是缘8

413191246se 发表于 2019-9-28 23:24
sylun 老师 辛苦了！请注意休息。相见 也注意休息。

感谢老师的关心！谢谢！