如何用VBA复制MS Word中List Paragraph的文本且不带列表编号

修改后可实现需求的完整代码 #

Private Sub CommandButton18_Click()
    Dim wordApp As New Word.Application
    Dim targetPara As Word.Paragraph
    Dim pureText As String
    Dim findResult As Boolean
    
    wordApp.Visible = True ' 调试阶段可保留，正式使用可删除
    ' 执行标题查找
    findResult = wordApp.Selection.Find.Execute(FindText:="Specific Heading")
    ' 增加查找结果判断，避免未找到标题时程序报错
    If Not findResult Then
        MsgBox "未匹配到指定标题"
        GoTo Cleanup
    End If
    
    wordApp.Selection.MoveDown Unit:=wdLine, Count:=1
    
    Do Until wordApp.Selection.Style <> "List Paragraph"
        Set targetPara = wordApp.Selection.Paragraphs(1)
        ' 核心逻辑：剔除列表编号前缀
        If targetPara.Range.ListFormat.ListType <> wdListNoNumbering Then
            ' ListString对应列表编号前缀（如"1. "），截取时跳过前缀即可
            pureText = VBA.Mid(targetPara.Range.Text, Len(targetPara.Range.ListFormat.ListString) + 2)
            ' 偏移量+2是适配编号后加空格的通用格式，可根据实际文档的编号后缀调整数值
        Else
            pureText = targetPara.Range.Text
        End If
        
        ' 若不需要复制到剪贴板，直接将pureText赋值到Excel单元格即可，性能更稳定
        ' 示例：ThisWorkbook.Sheets("汇总").Range("A" & 行号) = pureText
        ' 若需保留复制到剪贴板的逻辑，替换原有Copy代码为以下内容
        Dim dataObj As Object
        Set dataObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        dataObj.SetText pureText
        dataObj.PutInClipboard
        
        wordApp.Selection.MoveDown Unit:=wdParagraph, Count:=1
    Loop
    
Cleanup:
    ' 主动退出Word进程，避免后台残留冗余程序
    wordApp.Quit SaveChanges:=wdDoNotSaveChanges ' 可根据实际需求修改文档保存规则
    Set targetPara = Nothing
    Set wordApp = Nothing
End Sub

核心调整说明 #

• 取消直接复制段落Range的逻辑：Word的Range对象包含列表编号的隐藏域内容，直接复制必然会携带编号
• 通过ListFormat.ListString获取编号前缀后截取纯文本，全程不会修改原Word文档的内容
• 新增异常判断和进程清理逻辑，避免代码运行异常后后台残留Word进程占用资源

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