Sub ListNumbers02()
Dim objRegEx As Object
Dim objMatches As Object
Dim objMatch As Object
Dim strText As String
Dim strOutput As String
Dim objFSO As Object
Dim objFile As Object
Dim strFilePath As String
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Pattern = "\D\d{2}\.\d{3,4}\D"
strText = ActiveDocument.Range.Text
Set objMatches = objRegEx.Execute(strText)
For Each objMatch In objMatches
strOutput = strOutput & objMatch.Value & vbCrLf
Next objMatch
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = ActiveDocument.Path & "\Numbers.txt"
Set objFile = objFSO.CreateTextFile(strFilePath, True)
objFile.Write strOutput
objFile.Close
MsgBox "The list of numbers has been saved to " & strFilePath
End Sub