求前辈们帮忙实现这样的“查找替换”

13907933959 · 发表于 2017-5-12 16:44

本帖最后由 13907933959 于 2017-5-13 11:18 编辑

413191246se 发表于 2017-5-12 11:07
*** 139：请处理前备份文件，满意后再存盘！（复制代码到VBE中，关闭VBE，按 Alt+F8 再找 c打头的宏执行） ...

师傅好！
好久都没有看到您露面，一下写了这么多，真是辛苦！徒弟感谢！！！
师傅、我运行试了一下，有几处如有时间能不能再劳您优化一下：
1、c5好像运行不了。
2、c6在“模拟附件”上运行效果不太理想：
①、替换后，有的语句的位置不能在原地不动，其位置发生了比较大的改变。
②、有的多个（如2个以上的）上逗号不能统一替换为一个。有的语句前的上逗号没有紧靠语句前。
3、c8不能只准确锁定：单独另起一行的中文注释语及句号，统一替换为绿色，段落符的黑色不变。把有的用上逗号屏蔽了的语句也一起替换为了绿色。
4、还缺少一步：把单独另起一行，前面是英文字母，后面是中文的统一替换为紫色，段落符的黑色不变。
5、这几个宏能不能合为一个宏？

413191246se · 发表于 2017-5-13 01:45

139：建议一次来一个小问题，来一段示例文本，太多弄不清重新上传附件；还有，你用我这些旧代码想干什么呢？学习？要学的话，我建议你最好抽时间学学《微软官方VBA帮助》。下面是整合的宏：

Sub c合并代码()
With ActiveDocument.Content
.Font.Color = wdColorBlack '全文黑色
With .Find
.Execute FindText:="^l", ReplaceWith:="^p", Replace:=wdReplaceAll '手动换行符全部替换为段落标记
.Execute FindText:="^13", ReplaceWith:="^p", Replace:=wdReplaceAll '真假回车符全部替换为段落标记
.Execute FindText:="[!a-z0-9]@(')", ReplaceWith:=" \1", Replace:=wdReplaceAll, MatchWildcards:=True '单引号前空格替换为两个半角空格
.Execute FindText:="([a-z0-9])(')", ReplaceWith:="\1 \2", Replace:=wdReplaceAll, MatchWildcards:=True '单引号前空格替换为两个半角空格
'单引号全部替换为红色
.ClearFormatting
With .Replacement
.ClearFormatting
.Font.Color = wdColorRed
End With
.Execute FindText:="'", ReplaceWith:="", Format:=True, Replace:=wdReplaceAll
End With
End With
End Sub

复制代码

13907933959 · 发表于 2017-5-13 11:10

本帖最后由 13907933959 于 2017-5-13 11:11 编辑

413191246se 发表于 2017-5-13 01:45
139：建议一次来一个小问题，来一段示例文本，太多弄不清重新上传附件；还有，你用我这些旧代码想干什么呢 ...

师傅好！

好的、我用您的这些旧代码只是作为一个“模拟附件”用。

把语句前面数量不等的上逗号替换为1个，并让这个上逗号紧靠语句前，且语句的位置保持不动，语句前面只有1个上逗号的，如上逗号没有紧靠语句前的，让这个上逗号紧靠语句前，且语句的位置保持不动。上逗号以紧靠语句前的不动它。

413191246se · 发表于 2017-5-13 13:55

139：我认为你提供的附件还是大，再小一些，每个小问题只须2－3段示例文本即可。第6个小题我认为可以了，请测试：（还有小问题继续提供小附件，不必两个文件，在一个文档中即可。）

Sub c6多个单引号替换为一个_位置不变()
Dim i As Paragraph, j As Long
For Each i In ActiveDocument.Paragraphs
If i.Range Like "*'*" Then
i.Range.Characters(1).Select
Do While Selection.Characters.Last Like "[ ']"
Selection.MoveEnd unit:=wdCharacter, Count:=1
Loop
Selection.MoveEnd unit:=wdCharacter, Count:=-1
j = Len(Selection)
If Selection Like "*'*" Then
Selection = "'"
Selection.Font.Color = wdColorRed '红色（可删除/屏蔽）
Selection.Font.Bold = True '加粗（可删除/屏蔽）
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = (j - 1) / 2
Else
Selection = ""
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = j / 2
End If
End If
Next
End Sub

复制代码

13907933959 · 发表于 2017-5-13 15:14

413191246se 发表于 2017-5-13 13:55
139：我认为你提供的附件还是大，再小一些，每个小问题只须2－3段示例文本即可。第6个小题我认为可以了，请 ...

师傅好！

C6以解决，请看C3运行的效果。

413191246se · 发表于 2017-5-14 23:19

139：原来我为了图方便简单，用了查找的方法；但不准确，重新又用VBA宏的方法，用颜色标识不方便，后又改用下划线的方法明晰了，请测试：

Sub c3单引号前空格替换为两个半角空格()
'3、把语句后上逗号前数量不等的空格，统一替换为二个半角空格。
Dim i As Paragraph
For Each i In ActiveDocument.Paragraphs
If i.Range Like "*'*" Then
i.Range.Font.Color = wdColorPink '粉红（可删除/注释）
If i.Range Like "*[a-z]*'*" Then
i.Range.Font.Color = wdColorBlue '蓝色（可删除/注释）
If i.Range Like "*'*'*" Then
i.Range.Font.Underline = wdUnderlineDouble '双下划线（可删除/注释）--含有两个或以上单引号
'找到第一个英文字母，再找到撇号
i.Range.Characters(1).Select
Do
Selection.MoveEnd unit:=wdCharacter, Count:=1
Loop Until Selection.Characters.Last Like "[a-z]"
Selection.MoveEndUntil cset:="'", Count:=wdForward
Selection.MoveRight unit:=wdCharacter, Count:=1
Selection.MoveRight unit:=wdCharacter, Count:=1, Extend:=wdExtend
Do
Selection.MoveStart unit:=wdCharacter, Count:=-1
Loop Until Selection.Characters(1).Text <> " "
If Len(Selection) <> 2 Then Selection = Replace(Selection, " ", "")
Selection.Characters(1).InsertAfter Text:=" "
Else
i.Range.Font.Underline = wdUnderlineSingle '单下划线（可删除/注释）--仅含有一个单引号（也叫：撇号）
i.Range.Characters(InStr(i.Range, "'")).Select
Do
Selection.MoveStart unit:=wdCharacter, Count:=-1
Loop Until Selection.Characters(1).Text <> " "
If Len(Selection) <> 2 Then Selection = Replace(Selection, " ", "")
Selection.Characters(1).InsertAfter Text:=" "
End If
End If
End If
Next
End Sub

复制代码

duquancai · 发表于 2017-5-15 02:20

13907933959 发表于 2017-5-13 15:14
师傅好！C6以解决，请看C3运行的效果。

我来完成一个

Sub c3单引号前空格替换为两个半角空格()
' 3、把语句后上逗号前数量不等的空格，统一替换为二个半角空格。
Dim mts As Object, reg As Object, n&, m&, k&, j&
Set reg = CreateObject("vbscript.regexp")
reg.Global = True: reg.Pattern = "\w\s*'"
Set mts = reg.Execute(ActiveDocument.Content)
If Not mts Is Nothing Then
      For j = mts.Count - 1 To 0 Step -1
         m = mts(j).FirstIndex: n = mts(j).Length
         With ActiveDocument.Range(m, m + n)
            k = Len(.Text): .Collapse 0: .MoveStartWhile " '", -k
            .Text = "  '": .HighlightColorIndex = wdYellow'高亮黄色可自行取消！
         End With
      Next
End If
End Sub

13907933959 · 发表于 2017-5-15 06:33

413191246se 发表于 2017-5-14 23:19
139：原来我为了图方便简单，用了查找的方法；但不准确，重新又用VBA宏的方法，用颜色标识不方便，后又改用 ...

师傅好！
辛苦！辛苦！c3测试完美，现在是c5的问题，不知什么原因运行不了？

13907933959 · 发表于 2017-5-15 08:59

duquancai 发表于 2017-5-15 02:20
我来完成一个

Sub c3单引号前空格替换为两个半角空格()

杜前辈好！
感谢出手相助！
宏运行后，附件中有的另起一行的上逗号段落，不会呆在原来的位置，会往左移动。
我想只把语句后面的上逗号前数量不等的空格，统一替换为二个半角空格，另起一行的上逗号不动。

duquancai · 发表于 2017-5-15 09:23

13907933959 发表于 2017-5-15 08:59
杜前辈好！
感谢出手相助！
宏运行后，附件中有的另起一行的上逗号段落，不会呆在原来的位置，会往左移 ...

Sub c3单引号前空格替换为两个半角空格()
' 3、把语句后上逗号前数量不等的空格，统一替换为二个半角空格。
Dim mts As Object, reg As Object, n&, m&, k&, j&
Set reg = CreateObject("vbscript.regexp")
reg.Global = True: reg.Pattern = "\w[^\r]*'"
Set mts = reg.Execute(ActiveDocument.Content)
If Not mts Is Nothing Then
      For j = mts.Count - 1 To 0 Step -1
         m = mts(j).FirstIndex: n = mts(j).Length
         With ActiveDocument.Range(m, m + n)
            k = Len(.Text): .Collapse 0: .MoveStartWhile " '", -k
            .Text = "  '": .HighlightColorIndex = wdYellow '高亮黄色可自行取消！
         End With
      Next
End If
End Sub

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

[求助] 求前辈们帮忙实现这样的“查找替换”