将每组加粗的字符串，替换成单独的一段，段尾加上一个中文冒号

相见是缘8

求老师们帮忙！

将每组加粗的字符串，替换成单独的一段，段尾加上一个中文冒号。

请看“模拟附件”，谢谢！

cuanju

Sub dm3()
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Font.Bold = True
        .Format = True
        .Text = ""
        Do While .Execute
            With .Parent
                .InsertBefore Chr(13)
                .InsertAfter "：" & Chr(13)
                '  Stop
                If .End >= ActiveDocument.Content.End - 1 Then Exit Do
                .Collapse 0
            End With
        Loop
    End With
End Sub

相见是缘8

cuanju 发表于 2020-7-11 13:32
Sub dm3()
    With ActiveDocument.Content.Find
        .ClearFormatting

衷心感谢 cuanju 老师一路的援手！
代码 OK 完美！多谢老师！

gbgbxgb

相见是缘8 发表于 2020-7-11 18:06
衷心感谢 cuanju 老师一路的援手！
代码 OK 完美！多谢老师！

他（她）的代码处理你当前的附件还行吧，但如下情况的，该代码的处理就不尽人意了：
1.若某段落起始字符即为加粗格式，该代码仍然在字符前添加段落标记；
2.若段落标记符包含了字体加粗（姑且这么描述吧），代码将把“：”孤零零地添加在新起的段落上；3.若加粗的字符末尾正好已有“：”，代码还会再次添加“：”（这有点鸡蛋里挑骨头的味道了，可忽略）；
4.同前述2，若段落为一空段落，但该段落标记符包含了字体加粗格式的设置，“：”也无意义地被添加。

我在你的附件基础上添加了些文本和段落（纯粹为了给自己添加些难度），你可用该代码试试。

顺带粘贴我的代码于楼下。

修改了的模拟附件.rar (6.01 KB, 下载次数: 3)

2020-7-11 22:30 上传

点击文件名下载附件

gbgbxgb

可以较好地处理楼上附件情况的代码：

1. Sub the_InsertParagraph() '在加粗格式的字符后添加“：”并将其设置为新段落
   
2.     Dim rng As Range, i&, j&
   
3.     '
   
4.     Set rng = ThisDocument.Range(0, 0)
   
5.     With rng.Find
   
6.         .ClearFormatting
   
7.         .Text = ""
   
8.         .Font.Bold = True
   
9.         .Format = True
   
10.         Do While .Execute
    
11.             With .Parent
    
12.                 If .Characters(Len(.Text)) = vbCr Then .MoveEnd 1, -1
    
13.                 If .Text <> "" Then
    
14.                     If .Characters(Len(.Text)) <> "：" Then .InsertAfter "："
    
15.                     i = .MoveStart(1, -1)
    
16.                     If i <> 0 Then
    
17.                         If .Characters(1) <> vbCr Then
    
18.                             .MoveStart 1, 1
    
19.                             .InsertParagraphBefore
    
20.                         Else
    
21.                             .MoveStart 1, 1
    
22.                         End If
    
23.                     End If
    
24.                     '
    
25.                     i = .MoveEnd(1, 1)
    
26.                     If i <> 0 Then
    
27.                         If .Characters(Len(.Text)) <> vbCr Then
    
28.                             .MoveEnd 1, -1
    
29.                             .InsertParagraphAfter
    
30.                         Else
    
31.                             .MoveEnd 1, -1
    
32.                         End If
    
33.                     End If
    
34.                     .Collapse 0
    
35.                 Else
    
36.                     If .Move(1, 1) = 0 Then Exit Do
    
37.                 End If
    
38.             End With
    
39.         Loop
    
40.     End With
    
41.     Set rng = Nothing
    
42. End Sub

复制代码

相见是缘8

gbgbxgb 发表于 2020-7-11 19:54
可以较好地处理楼上附件情况的代码：

gbgbxgb老师好！
好久没看到你露面，感谢你的代码及提示！
cuanju 老师的代码，只是针对我提供的附件，来满足我提出的粗略要求，因我没有提出更细的要求（我一般都是自己解决不了的大问题求老师们解决，剩下的小问题再自己解决），所以我说是完美的。
老师你不但 VBA 水平是顶级，考虑问题也更周前，把文件处理中将会遇到的各种问题及风险都想到，在代码中都给归避了，我想这也是你的代码，为什么总是那么超级完美的原因！
老师、能请你把代码改一下，放在 “NewMacros” 中使用吗？谢谢！