修改VBA代码：提取文档中字符串关联的高频参考编号

以下是满足需求的修改后代码，能遍历文档中所有带关联编号的目标字符串实例，统计出现频次最高的编号，无有效关联时输出指定文本：

Sub FindMostFrequentRefNumeral()
    Dim targetString As String
    Dim foundRange As Range
    Dim numeral As String
    Dim numeralDict As Object
    Dim maxCount As Integer
    Dim result As String
    
    ' 获取用户输入的目标字符串
    targetString = InputBox("Feature:")
    If targetString = "" Then Exit Sub ' 空输入直接退出
    
    ' 初始化字典用于统计编号频次
    Set numeralDict = CreateObject("Scripting.Dictionary")
    
    ' 初始化查找范围
    Set foundRange = ActiveDocument.Content
    With foundRange.Find
        .Text = targetString & " [0-9]{1,3}[A-Za-z]*"
        .MatchWildcards = True
        .Forward = True
        .Wrap = wdFindStop ' 避免循环查找
        
        ' 遍历所有匹配结果
        Do While .Execute
            ' 提取关联编号（分割后取最后一段）
            numeral = Split(foundRange.Text, " ")(UBound(Split(foundRange.Text, " ")))
            ' 更新字典中的频次统计
            If numeralDict.Exists(numeral) Then
                numeralDict(numeral) = numeralDict(numeral) + 1
            Else
                numeralDict.Add numeral, 1
            End If
        Loop
    End With
    
    ' 处理统计结果
    If numeralDict.Count = 0 Then
        result = "no numeral"
    Else
        ' 找出最高频次
        maxCount = 0
        For Each key In numeralDict.Keys
            If numeralDict(key) > maxCount Then
                maxCount = numeralDict(key)
                result = key & " (出现" & maxCount & "次)"
            ElseIf numeralDict(key) = maxCount Then
                ' 若有多个编号频次相同，追加到结果中
                result = result & ", " & key & " (出现" & maxCount & "次)"
            End If
        Next key
    End If
    
    ' 弹出结果
    MsgBox "统计结果: " & result, vbInformation
End Sub

关键改动说明 #

• 使用Scripting.Dictionary存储每个关联编号的出现次数，实现高效的频次统计
• 通过Do While .Execute循环遍历文档中所有匹配的实例，替代原代码只查找一次的逻辑
• 增加空输入判断，避免无效执行
• 处理多个编号频次并列最高的情况，会将所有最高频次的编号都展示出来
• 严格按照需求，无关联编号时输出no numeral

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