编写VBA宏提取所有文内引用并导出至其他文档

我正在制作一个VBA宏，用于识别文档中的文内引用并导出到其他文档。目前已实现部分功能，但仅能识别部分引用格式，需要覆盖所有带括号和不带括号的引用场景，具体包括：

• 单作者：(史密斯, 2015) 或 史密斯 (2015)（例：……史密斯 (2015) 指出……）
• 双作者：(史密斯和琼斯, 2015) 或 史密斯和琼斯 (2015)（例：……根据史密斯和琼斯 (2015) 的研究……）
• 三作者：(史密斯, 琼斯和布朗, 2015) 或 史密斯, 琼斯和布朗 (2015)（例：……史密斯、琼斯和布朗 (2015) 的研究表明……）
• 多作者：(史密斯等人, 2015) 或 史密斯等人 (2015)（例：史密斯等人 (2015) 证实了……）

原代码（已译中文） #

之前使用的代码仅能识别部分带括号的引用，代码如下：

Sub 从选中内容提取引用()
    MsgBox "此宏将从选中的文本中提取引用。"
    Dim 查找范围 As Range, 目标文档名$, 源文档名$
    目标文档名$ = "引用汇总.doc"
    源文档名$ = ActiveDocument.Name
    Documents.Add DocumentType:=wdNewBlankDocument
    ActiveDocument.SaveAs 目标文档名$, wdFormatDocument
    Documents(源文档名$).Activate
    Set 查找范围 = ActiveDocument.Range
    With 查找范围.Find
        .ClearFormatting
        .Text = "\([!\)]@[0-9]{4}\)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        While .Execute
            Documents(目标文档名$).Range.Text = Documents(目标文档名$).Range.Text + 查找范围.Text
        Wend
    End With
End Sub

原代码的通配符表达式仅能匹配括号包裹的完整引用，无法识别作者在前、年份单独在括号里的格式，且对作者名称的匹配逻辑不够精准，会遗漏大量符合要求的引用。

优化后的宏代码 #

以下代码可同时识别两种格式的引用，还能自动去重，避免重复导出相同内容：

Sub 提取所有文内引用()
    MsgBox "此宏将提取文档中所有符合格式的文内引用并导出到新文档。"
    
    Dim 查找范围 As Range, 目标文档 As Document, 源文档 As Document
    Dim 引用集合 As New Collection, 引用文本 As String
    Dim i As Integer
    
    ' 设置源文档和创建目标文档
    Set 源文档 = ActiveDocument
    Set 目标文档 = Documents.Add(DocumentType:=wdNewBlankDocument)
    目标文档.SaveAs "引用汇总.doc", wdFormatDocument
    
    ' 定义两种引用格式的通配符模式
    Dim 模式1 As String, 模式2 As String
    ' 模式1：括号包裹的完整引用 (作者, 年份) 或 (作者和作者, 年份) 等
    模式1 = "\([A-Za-z\u4e00-\u9fa5]+([, ]+(and|和|et al\.|等人))?[A-Za-z\u4e00-\u9fa5]*, [0-9]{4}\)"
    ' 模式2：作者在前，年份在括号里 作者 (年份) 或 作者和作者 (年份) 等
    模式2 = "[A-Za-z\u4e00-\u9fa5]+([, ]+(and|和|et al\.|等人))?[A-Za-z\u4e00-\u9fa5]* \([0-9]{4}\)"
    
    ' 遍历两种模式查找引用
    For Each 模式 In Array(模式1, 模式2)
        Set 查找范围 = 源文档.Range
        With 查找范围.Find
            .ClearFormatting
            .Text = 模式
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWildcards = True
            
            Do While .Execute
                引用文本 = Trim(查找范围.Text)
                ' 尝试添加到集合去重
                On Error Resume Next
                引用集合.Add 引用文本, Key:=引用文本
                On Error GoTo 0
            Loop
        End With
    Next 模式
    
    ' 将去重后的引用写入目标文档
    If 引用集合.Count > 0 Then
        For i = 1 To 引用集合.Count
            目标文档.Range.Text = 目标文档.Range.Text & 引用集合(i) & vbCrLf
        Next i
        MsgBox "共提取 " & 引用集合.Count & " 条唯一引用，已保存到 引用汇总.doc"
    Else
        MsgBox "未找到符合格式的引用。"
    End If
    
    ' 激活源文档
    源文档.Activate
End Sub

代码说明 #

1. 通配符模式优化：定义两种匹配模式，覆盖括号包裹的完整引用和作者前置的引用场景，同时支持中英文作者名称识别。
2. 去重处理：使用Collection存储引用，利用键值唯一性自动去重，避免导出重复内容。
3. 格式整理：导出的引用自动换行，提升可读性。
4. 状态提示：完成后弹出提示，告知提取的引用数量。

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