使用 VBA 提取带有模式的文本字符串

Question

我正在尝试用 VBA 编写一个脚本，从 MS Word 文档中恢复以两个大写字母开头、后跟四到十五个数字的任何文本字符串，忽略空格、“-”和“/”。文本字符串的最大长度为 18 个字符。

我希望将提取的数字作为列表打印在另一个 Word 或 Excel 文档上。
典型的字符串可以是“BN 123456”或“NH123456”或“ZB20458-9654”，它们将被列为

"BN 123456"
"NH123456"
"ZB20458-9654"

每次在 Word 中运行脚本时，我都会收到消息“未找到匹配项”。我认为我无法让程序到达搜索模式的部分

Sub RecoverText()
    Dim doc As Document
    Dim rng As Range
    Dim pattern As String
    Dim matches As Object
    Dim match As Variant
    
    ' Define the regex pattern to find strings starting with two capital letters, a space, and four to fifteen numbers
    pattern = "\b[A-Z]{2}\s\d{4,15}\b"
    
    ' Create a new document to store the recovered strings
    Set doc = Documents.Add
    
    ' Set the range to search the entire document
    Set rng = ActiveDocument.Content
    
    ' Find all matches using regex
    Set matches = CreateObject("VBScript.RegExp")
    With matches
        .Global = True
        .IgnoreCase = True
        .MultiLine = True
        .pattern = pattern
    End With
    
    ' Iterate through each match and add it to the new document
    For Each match In matches.Execute(rng.Text)
        ' Check if the length of the matched string is less than or equal to 18 characters
        If Len(match.Value) <= 18 Then
            doc.Content.InsertAfter match.Value & vbCrLf
        End If
    Next match
    
    ' Display the new document
    doc.Activate
    
    ' Notify user if no matches were found
    If matches.Execute(rng.Text).Count = 0 Then
        MsgBox "No matches found."
    End If
End Sub

Answer 1

试试这个：

Option Explicit

Sub RecoverText()
    Dim doc As Document, matches As Collection, m
    
    Set matches = AllMatches(ActiveDocument.Content)
    If matches.Count > 0 Then
        Set doc = Documents.Add
        For Each m In matches
            doc.Content.InsertAfter m & vbCrLf
        Next m
    Else
        MsgBox "No matches found."
    End If
    
End Sub

'Return a collection of all matches for PATTERN in `txt`
Function AllMatches(txt As String) As Collection
    Const PATTERN As String = "\b[A-Z]{2}[\s-/]*[\d-/]{4,15}\b" 'allow for spaces, - and /
    Dim match As Variant
    
    Set AllMatches = New Collection
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = True
        .MultiLine = True
        .PATTERN = PATTERN
        For Each match In .Execute(txt)
            If Len(match.Value) <= 18 Then
                AllMatches.Add match.Value
            End If
        Next match
    End With
End Function