Word VBA宏能否提取参会者不同段落的多类状态信息？

你的需求完全可行，只需调整现有VBA代码的逻辑，加入参会者信息的分组存储，就能实现跨段落提取同一参会者的多类信息。

核心思路调整 #

现有代码是按段落逐个处理标题（加粗下划线文本）和对应值，没有关联同一参会者的不同属性。你需要：

• 识别每个参会者的起始标记（比如参会者姓名作为标题）
• 用字典或自定义类存储该参会者的所有属性（公民身份、到场状态、陪同情况等）
• 处理完一个参会者的所有属性后，统一生成格式化文本插入到文档中

修改后的示例代码 #

Sub Compa()
    Dim objDoc As Document
    Dim rgSignetA As Range, rgSignetB As Range
    Dim objPara As Paragraph
    Dim strCurrentAttendee As String ' 当前跟踪的参会者姓名
    Dim attendeeInfo As New Dictionary ' 存储参会者的各类信息
    Dim strResultat As String
    Dim rgInsertionPoint As Range
    Dim strTxtParagrahe As String
    
    On Error GoTo erreur
    Set objDoc = ActiveDocument
    Set rgSignetA = objDoc.Bookmarks("P").Range
    Set rgSignetB = objDoc.Bookmarks("D").Range
    
    strResultat = ""
    
    For Each objPara In objDoc.Paragraphs
        ' 只处理书签P到D之间的段落
        If objPara.Range.Start >= rgSignetA.Start And objPara.Range.End <= rgSignetB.End Then
            strTxtParagrahe = Left(objPara.Range.Text, Len(objPara.Range.Text) - 1)
            If strTxtParagrahe <> "" Then
                ' 判断是否是参会者姓名标记（假设是加粗下划线格式）
                If objPara.Range.Font.Bold = True And objPara.Range.Font.Underline = wdUnderlineSingle Then
                    ' 如果已有之前的参会者信息，先写入结果
                    If strCurrentAttendee <> "" Then
                        strResultat = strResultat & FormatAttendeeInfo(strCurrentAttendee, attendeeInfo) & vbCrLf & vbCrLf
                        attendeeInfo.RemoveAll ' 清空字典准备下一个参会者
                    End If
                    strCurrentAttendee = strTxtParagrahe ' 更新当前参会者
                Else
                    ' 拆分属性名称和值（假设段落格式是"属性: 值"）
                    Dim arrProp() As String
                    arrProp = Split(strTxtParagrahe, ":", 2)
                    If UBound(arrProp) = 1 Then
                        Dim propName As String, propValue As String
                        propName = Trim(arrProp(0))
                        propValue = Trim(arrProp(1))
                        ' 把属性存入字典
                        attendeeInfo(propName) = TranslateValue(propValue)
                    End If
                End If
            End If
        End If
    Next objPara
    
    ' 处理最后一个参会者的信息
    If strCurrentAttendee <> "" Then
        strResultat = strResultat & FormatAttendeeInfo(strCurrentAttendee, attendeeInfo)
    End If
    
    ' 插入结果到书签B之后
    Set rgInsertionPoint = rgSignetB.Paragraphs.Last.Range
    rgInsertionPoint.Collapse Direction:=wdCollapseEnd
    rgInsertionPoint.InsertAfter vbCrLf & strResultat
    
fin:
    ' 释放对象
    Set attendeeInfo = Nothing
    Set rgInsertionPoint = Nothing
    Set rgSignetA = Nothing
    Set rgSignetB = Nothing
    Set objDoc = Nothing
    Exit Sub
erreur:
    MsgBox "错误: " & Err.Description & "(" & Err.Number & ")", vbCritical, "Compa"
End Sub

' 辅助函数：转换原始值为目标表述
Function TranslateValue(originalValue As String) As String
    Select Case LCase(originalValue)
        Case "present"
            TranslateValue = "已到场"
        Case "present with translator"
            TranslateValue = "已到场，配有翻译"
        Case "citizen"
            TranslateValue = "是本国公民"
        Case "accompanied"
            TranslateValue = "有陪同人员"
        Case Else
            TranslateValue = originalValue
    End Select
End Function

' 辅助函数：格式化参会者信息为最终文本
Function FormatAttendeeInfo(attendeeName As String, infoDict As Dictionary) As String
    Dim result As String
    result = attendeeName & ":" & vbCrLf
    Dim key As Variant
    For Each key In infoDict.Keys
        result = result & "- " & key & ": " & infoDict(key) & vbCrLf
    Next key
    FormatAttendeeInfo = result
End Function

关键说明 #

1. 字典存储：用Dictionary对象临时存储单个参会者的所有属性，确保不同段落的信息能关联到同一人
2. 辅助函数拆分：把值转换和文本格式化的逻辑拆成独立函数，方便后续添加更多属性规则
3. 参会者边界处理：当遇到新的参会者标题时，先把上一个参会者的信息写入结果，避免遗漏

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