Word VBA在指定书签后插入动态项目列表首项格式不生效问题

根因分析 #

• 循环内重复读取emails书签的原始位置，每次新段落都插入到书签的原始位置，之前插入的段落会被挤到后方，导致第一个段落的格式应用逻辑错位
• 给段落文本末尾额外添加了vbCr换行符，相当于每个内容段落后多生成了一个空白段落，最终就会在列表末尾出现多余的空白项目符号
• 段落范围未做折叠处理，后续插入的内容会覆盖之前的范围位置

修复方案 #

1. 将书签存在性判断移到循环外，仅执行一次避免重复消耗性能
2. 首次获取书签范围后就折叠到末尾，保证所有内容都插入到书签之后
3. 移除文本末尾多余的vbCr，段落对象本身自带分段属性，无需额外添加换行符
4. 每插入一个段落就将范围折叠到末尾，保证下一个段落顺次追加在后方

修正后完整代码 #

Dim temp3 As ListTemplate
Set temp3 = ListGalleries(wdNumberGallery).ListTemplates(1)
With temp3.ListLevels(1)
    .Font.Name = "Symbol"
    .Font.Size = 11
    .NumberFormat = ChrW(61623)
    .TrailingCharacter = wdTrailingTab
    .NumberStyle = wdListNumberStyleArabic
    .Alignment = wdListLevelAlignLeft
    .TabPosition = wdUndefined
    .StartAt = 1
End With

Dim oRangeBKM As Range
Dim paragraph As Paragraph
Dim idx As Integer: idx = 1 ' 补充原代码缺失的idx计数器初始化

' 提前判断书签是否存在，无需在循环内重复执行
If ActiveDocument.Bookmarks.Exists("emails") Then
    Set oRangeBKM = ActiveDocument.Bookmarks("emails").Range
    ' 折叠到书签末尾，保证内容插在书签之后
    oRangeBKM.Collapse wdCollapseEnd
    
    For Each k In entities
        Set paragraph = oRangeBKM.Paragraphs.Add
        ' 移除多余的vbCr，避免生成额外空白段落
        paragraph.Range.Text = k("entity") & CStr(idx)
        paragraph.Range.Style = wdStyleHeading2
        ' 应用列表格式
        paragraph.Range.ListFormat.ApplyListTemplate ListTemplate:=temp3
        ' 折叠到当前内容末尾，下一段顺次追加
        oRangeBKM.Collapse wdCollapseEnd
        idx = idx + 1
    Next
End If

内容的提问来源于stack exchange，提问作者anekix