VBA代码求助：查找文本后选中整行并复制至新表格

以下是修改后的完整代码，可实现查找指定关键词、定位到内容所在整行（段落）并复制到新文档的表格中：

Sub FindMultiItemsInDocAndCopyRows()
    Dim objListDoc As Document
    Dim objTargetDoc As Document
    Dim objNewDoc As Document
    Dim objTable As Table
    Dim objParaRange As Range, objFoundRange As Range
    Dim objParagraph As Paragraph
    Dim strFileName As String
    Dim rowNum As Integer
    
    ' 获取列表文档路径
    strFileName = InputBox("输入列表文档的完整路径：")
    If strFileName = "" Then Exit Sub ' 用户取消输入则退出
    
    ' 初始化文档对象
    Set objTargetDoc = ActiveDocument
    Set objListDoc = Documents.Open(strFileName)
    Set objNewDoc = Documents.Add ' 创建新文档用于存放结果
    Set objTable = objNewDoc.Tables.Add(Range:=objNewDoc.Range, NumRows:=1, NumColumns:=1) ' 创建初始表格
    objTable.Cell(1, 1).Range.Text = "匹配到的行内容" ' 设置表头
    rowNum = 2 ' 从第二行开始添加内容
    
    objTargetDoc.Activate
    
    ' 遍历列表文档中的每个查找关键词
    For Each objParagraph In objListDoc.Paragraphs
        Set objParaRange = objParagraph.Range
        objParaRange.End = objParaRange.End - 1 ' 去掉段落标记
        
        ' 跳过空段落
        If Trim(objParaRange.Text) = "" Then GoTo NextPara
        
        ' 在目标文档中查找所有匹配项
        Set objFoundRange = objTargetDoc.Content
        With objFoundRange.Find
            .ClearFormatting
            .Text = objParaRange.Text
            .MatchWholeWord = True
            .MatchCase = False
            .Forward = True
            .Wrap = wdFindStop
            
            ' 循环查找所有匹配结果
            Do While .Execute
                ' 选中匹配内容所在的整段（行）
                objFoundRange.Paragraphs(1).Range.Select
                ' 复制该段落内容
                Selection.Copy
                
                ' 在新表格中添加行并粘贴内容
                objTable.Rows.Add
                objTable.Cell(rowNum, 1).Range.Paste
                rowNum = rowNum + 1
            Loop
        End With
        
NextPara:
    Next objParagraph
    
    ' 关闭列表文档，不保存
    objListDoc.Close SaveChanges:=wdDoNotSaveChanges
    MsgBox "匹配完成，结果已保存到新文档！"
End Sub

关键改动说明 #

• 新增了新文档和表格对象，专门用于存放匹配结果，避免污染原文档
• 处理空段落，防止无效查找
• 改用范围查找替代选区查找，逻辑更稳定，无需依赖当前选中状态
• 循环查找所有匹配项，不会漏掉重复出现的关键词
• 通过Paragraphs(1).Range定位到匹配内容所在的整行（段落），确保复制完整行内容
• 自动关闭列表文档并弹出完成提示，优化操作流程

内容的提问来源于stack exchange，提问作者Thien Nguyen Huynh