VBA宏优化需求：筛选特定字符串并生成有序参考数字列表

核心问题修复方案 #

1. 精准过滤非目标字符串 #

通过正则表达式匹配规则结合排除词表实现精准过滤：

• 正则匹配独立的字母单词（大小写不敏感）+ 空格 + 数字的组合
• 自定义排除词数组，对匹配到的单词二次校验，排除as、and、between这类非目标词

2. 按数字升序排列 #

用字典存储去重数据，提取数据后拆分出数字部分，以此为依据完成升序排序

完整修正代码 #

Sub ExtractAndSortReferences()
    Dim regEx As Object
    Dim matches As Object
    Dim match As Object
    Dim excludeWords As Variant
    Dim refDict As Object
    Dim key As Variant
    Dim sortedItems() As String
    Dim i As Integer, j As Integer
    Dim temp As String
    Dim num1 As Integer, num2 As Integer
    
    ' 初始化正则表达式
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    regEx.IgnoreCase = True
    ' 匹配：独立字母单词 + 空格 + 至少1位数字
    regEx.Pattern = "\b([A-Za-z]+)\s+(\d+)\b"
    
    ' 定义需排除的非目标单词数组
    excludeWords = Array("as", "and", "between", "claim", "figure")
    
    ' 初始化字典用于去重存储
    Set refDict = CreateObject("Scripting.Dictionary")
    refDict.CompareMode = vbTextCompare ' 大小写不敏感去重
    
    ' 遍历文档查找所有匹配项
    Set matches = regEx.Execute(ActiveDocument.Content.Text)
    For Each match In matches
        Dim targetWord As String
        targetWord = LCase(match.SubMatches(0))
        ' 检查是否属于排除词
        If Not IsInArray(targetWord, excludeWords) Then
            Dim refKey As String
            refKey = match.SubMatches(0) & "(" & match.SubMatches(1) & ")"
            If Not refDict.Exists(refKey) Then
                refDict.Add refKey, CInt(match.SubMatches(1)) ' 存数字用于排序
            End If
        End If
    Next match
    
    ' 将字典项转入数组准备排序
    If refDict.Count > 0 Then
        ReDim sortedItems(0 To refDict.Count - 1)
        i = 0
        For Each key In refDict.Keys
            sortedItems(i) = key
            i = i + 1
        Next key
        
        ' 按数字部分升序排序（冒泡排序）
        For i = 0 To UBound(sortedItems) - 1
            For j = i + 1 To UBound(sortedItems)
                ' 提取字符串中的数字部分
                num1 = CInt(Mid(sortedItems(i), InStr(sortedItems(i), "(") + 1, InStr(sortedItems(i), ")") - InStr(sortedItems(i), "(") - 1))
                num2 = CInt(Mid(sortedItems(j), InStr(sortedItems(j), "(") + 1, InStr(sortedItems(j), ")") - InStr(sortedItems(j), "(") - 1))
                If num1 > num2 Then
                    temp = sortedItems(i)
                    sortedItems(i) = sortedItems(j)
                    sortedItems(j) = temp
                End If
            Next j
        Next i
        
        ' 输出结果（可替换为写入文档、生成新段落等）
        MsgBox "去重并排序后的列表：" & vbCrLf & Join(sortedItems, vbCrLf)
    Else
        MsgBox "未找到符合要求的参考项"
    End If
    
    ' 释放对象
    Set regEx = Nothing
    Set matches = Nothing
    Set refDict = Nothing
End Sub

' 辅助函数：检查字符串是否在数组内
Function IsInArray(searchStr As String, arr As Variant) As Boolean
    Dim element As Variant
    For Each element In arr
        If LCase(element) = searchStr Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function

关键代码说明 #

1. 正则表达式优化：

   • 模式\b([A-Za-z]+)\s+(\d+)\b确保匹配独立的单词+数字组合，避免误匹配长单词的片段
   • IgnoreCase = True实现大小写统一校验

2. 排除词过滤：

   • excludeWords数组可自由添加/删除需排除的单词，IsInArray函数快速完成匹配校验

3. 排序逻辑：

   • 字典存储时同步记录对应数字，排序时从结果字符串中提取数字并转为整数比较，保证按数字升序排列
   • 冒泡排序适用于数据量不大的场景，若需处理大量数据可替换为更高效的排序算法

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