我正在尝试用 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
试试这个:
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