Match all dates without an asterisk in front - regex

I'm trying to use negative lookback to match all dates without an asterisk in front but it doesn't seem to be working.
(?<!\\*)(\b(?:0[1-9]|[0-2])/(?:0[1-9]|[12]\d|3[01])/(?:19\d{2}|[2-9]\d{3})\b)
This is the string I'm trying to match:
02/02/2019 *03/20/2019 AB CART 9000341 FAXED TO INSTITUTION
Here's the full code for what I have. It extracts the most recent date preceding the word faxed. The problem is if there is a date with an asterisk in front of it (such as *03/20/2019) it chooses that instead of the date (02/02/2019)
This is the Function:
Option Explicit
Function lastFaxedDt(s As String) As Date
Dim re As RegExp, MC As MatchCollection
Const sPat As String = "(\b(?:0[1-9]|1[0-2])/(?:0[1-9]|[12]\d|3[01])/(?:19\d{2}|[2-9]\d{3})\b)(?=.*?faxed)"
Set re = New RegExp
With re
.Pattern = sPat
.IgnoreCase = True
.Global = True
If .Test(s) = True Then
Set MC = .Execute(s)
lastFaxedDt = CDate(MC(MC.Count - 1))
End If
End With
End Function
This is the Macro:
Sub ExtractDate()
marker = 0
Set objShell = CreateObject("Shell.Application")
IE_count = objShell.Windows.Count
For x = 0 To (IE_count - 1)
On Error Resume Next
my_url = objShell.Windows(x).document.Location
my_title = objShell.Windows(x).document.Title
If my_title Like "RFT" & "*" Then
Set IE = objShell.Windows(x)
marker = 1
Exit For
Else
End If
Next
Dim Text As String
Text = Trim$(IE.document.getElementById("ctl00_ContentPlaceHolder1_txtNotes").innerText)
ExtractedDate = lastFaxedDt(Text)
If ExtractedDate = "12:00:00 AM" Then
ExtractedDate = "0"
Else
End If
ExtractedDate = CLng(ExtractedDate)
MaxDate = Application.WorksheetFunction.Max(ExtractedDate)
If MaxDate = "0" Then
MsgBox "No Date Found"
Else
End If
MaxDate = CDate(MaxDate)
Dim ws5 As Worksheet: Set ws5 = ActiveWorkbook.ActiveSheet
ws5.Range("C" & (ActiveCell.Row)).Value = MaxDate
Range("C" & (ActiveCell.Row)).NumberFormat = "[$-409]d-mmm;#"
End Sub

As mentioned in the comments, VBA does not support Lookbehinds. To work around this, you can replace your Lookbehind with the following:
(?:^|[^*])
And then find the date in the capturing group (sub-match) instead of the full match. In this case, your function should look something like this:
Function lastFaxedDt(s As String) As Date
Const sPat As String = _
"(?:^|[^*])" & _
"(\b(?:0[1-9]|1[0-2])/(?:0[1-9]|[12]\d|3[01])/(?:19\d{2}|[2-9]\d{3})\b)" & _
"(?=.*?faxed)"
Dim re As New RegExp, matches As MatchCollection
With re
.Pattern = sPat
.IgnoreCase = True
.Global = True
Set matches = .Execute(s)
If matches.Count > 0 Then
Dim lastMatch As Match: Set lastMatch = matches(matches.Count - 1)
lastFaxedDt = CDate(lastMatch.SubMatches.Item(0))
Else
' TODO: handle the case where no matches are found
End If
End With
End Function
Usage:
Dim s As String
s = "02/02/2019 *03/20/2019 AB CART 9000341 FAXED TO INSTITUTION"
MsgBox lastFaxedDt(s) ' 02/02/2019

Related

Splitting a string and capitalizing letters based on cases

I have some column names with starting coding convention that I would like to transform, see example:
Original Target
------------- --------------
partID Part ID
completedBy Completed By
I have a function in VBA that splits the original string by capital letters:
Function SplitCaps(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "([a-z])([A-Z])"
SplitCaps = .Replace(strIn, "$1 $2")
End With
End Function
I wrap this function within PROPER, for example, PROPER(SplitCaps(A3)) produces the desired result for the third row but leaves the "D" in ID uncapitalized.
Original Actual
------------- --------------
partID Part Id
completedBy Completed By
Can anyone think of a solution to add cases to this function?
split the word and loop the results and test whether it is all caps before using Proper. then join them back:
Sub kjl()
Dim str As String
str = "partID"
Dim strArr() As String
strArr = Split(SplitCaps(str), " ")
Dim i As Long
For i = 0 To UBound(strArr)
If UCase(strArr(i)) <> strArr(i) Then
strArr(i) = Application.Proper(strArr(i))
End If
Next i
str = Join(strArr, " ")
Debug.Print str
End Sub
If you want a formula to do what you are asking then:
=TEXTJOIN(" ",TRUE,IF(EXACT(UPPER(TRIM(MID(SUBSTITUTE(SplitCaps(A1)," ",REPT(" ",999)),{1,999},999))),TRIM(MID(SUBSTITUTE(SplitCaps(A1)," ",REPT(" ",999)),{1,999},999))),TRIM(MID(SUBSTITUTE(SplitCaps(A1)," ",REPT(" ",999)),{1,999},999)),PROPER(TRIM(MID(SUBSTITUTE(SplitCaps(A1)," ",REPT(" ",999)),{1,999},999)))))
Entered as an array formula by confirming with Ctrl-Shift-Enter instead of Enter when exiting edit mode.
Or use the code above as a Function:
Function propSplitCaps(str As String)
Dim strArr() As String
strArr = Split(SplitCaps(str), " ")
Dim i As Long
For i = 0 To UBound(strArr)
If UCase(strArr(i)) <> strArr(i) Then
strArr(i) = Application.Proper(strArr(i))
End If
Next i
propSplitCaps = Join(strArr, " ")
End Function
and call it =propSplitCaps(A1)
Instead of using the Proper function, just capitalize the first letter of each word after you have split the string on the transition.
Option Explicit
Function Cap(s As String) As String
Dim RE As RegExp, MC As MatchCollection, M As Match
Const sPatSplit = "([a-z])([A-Z])"
Const sPatFirstLtr As String = "\b(\w)"
Const sSplit As String = "$1 $2"
Set RE = New RegExp
With RE
.Global = True
.Pattern = sPatSplit
.IgnoreCase = False
If .Test(s) = True Then
s = .Replace(s, sSplit)
.Pattern = sPatFirstLtr
Set MC = .Execute(s)
For Each M In MC
s = WorksheetFunction.Replace(s, M.FirstIndex + 1, 1, UCase(M))
Next M
End If
End With
Cap = s
End Function

How do I filter for a specific word (map) then capture the next text up until the next space?

I am trying to get the text right after - Map in this case example it is "AVE_NMHG_I_214_4010_XML_SAT" and input that into each Map Name row within the column up until the next space character found in could end up being "AVE_I_214_4010" as another example.
this is where I'm trying to make this fit.
Dim tmp As String
Dim RegX2 As Object, Mats1 As Object
tmp = strColS
Set RegX2 = CreateObject("VBScript.RegExp")
With RegX2
.Global = True
.Pattern = "Map\d{7}"
Set Mats1 = .Execute(tmp)
End With
If (RegX2.Test(tmp)) Then
Set Mats1 = RegX2.Execute(tmp)
tmp = Mats1(0)
Else
With RegX2
.Pattern = "MAP\d{9}"
Set Mats1 = .Execute(tmp)
End With
If (RegX.Test(tmp)) Then
tmp = Mats1(0)
End If
End If
Set Mats1 = Nothing
Set RegX2 = Nothing
Note: there isn't always a Map specified and sometimes it is defined as MAP or map.
This code works by selecting the emails in outlook and then running the macro for only that selected emails.
This is an example of a subject that has the
Example Subject
RE: TS001889493 - Translation failure - Inbound - ( VEXP/ HONCE/ Document Type 214 - Map AVE_NMHG_I_214_4010_XML_SAT - Error Conditional Relationship Error in N103 (0066) [ ref:_00D50c9MW._5000z1J3cG8:ref ]
Example of body
Dear Valued Trading Partner,
We received the attached 214 transactions from Sender ID: VEXP/ Receiver ID: HONCE that failed due to Conditional Relationship Error in the N1_03 (0066).
As per the map logic, If either N103 or N104 is present, then the other is required as they are in conditional relationship with each other. But in the input file received, N104 value is missing hence the error.
Transaction Details: #4# Attached
Please correct and resend the data.
Thank you, Simon Huggs | Sass support - Basic
What happens in the #num# is that it gets the sum of all these after making a match of the "TS" ticket ID.
This is the code I have up until now
Option Explicit
Sub WritingTicketNumberAndfailuresnew()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount, STicket, SticketNumber As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath, SSubject As String
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColS, strColB, sassupport, sMailDateReceived, SFrom As String
Dim Actions1, Actions2, Actions3, Actions4 As Boolean
Dim I, cnt, email_needed As Integer
' Get Excel set up
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open a specific workbook to input the data the path of the workbook under the windows user account
enviro = CStr(Environ("USERPROFILE"))
strPath = enviro & "\Documents\topthreeticket.xlsx"
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
' Add column names
xlSheet.Range("A1") = "Email Subject"
xlSheet.Range("B1") = "Map Name"
xlSheet.Range("C1") = "Case Number"
xlSheet.Range("D1") = "No. Of Failures"
xlSheet.Range("E1") = "Date"
xlSheet.Range("F1") = "Week Number"
sassupport = "sassuport#sass.com"
On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'collect the fields for ticket number and failure count
strColS = olItem.Subject
strColB = olItem.Body
SFrom = olItem.SenderEmailAddress
sMailDateReceived = olItem.ReceivedTime
Dim sFailures, stmp1, stmp2, stmp3 As String
Dim RegX As Object, Mats As Object
Dim Found As Boolean
' Check the number of failures from body
sFailures = "0"
stmp1 = strColB
Set RegX = CreateObject("VBScript.RegExp")
With RegX
.Global = True
.Pattern = "#\d+#"
Set Mats = .Execute(stmp1)
End With
If (RegX.Test(stmp1)) Then
stmp2 = Mats(0)
Found = True
stmp3 = Mid(stmp2, 2, Len(stmp2) - 2)
sFailures = stmp3
Else
With RegX
.Pattern = "#d\d+"
Set Mats = .Execute(stmp1)
End With
If (RegX.Test(stmp1)) Then
stmp2 = Mats(0)
Found = True
stmp3 = Mid(stmp2, 2, Len(stmp2) - 1)
sFailures = stmp3
End If
End If
Set Mats = Nothing
Set RegX = Nothing
Dim tmp As String
Dim RegX2 As Object, Mats1 As Object
tmp = strColS
Set RegX2 = CreateObject("VBScript.RegExp")
With RegX2
.Global = True
.Pattern = "Map\d{7}"
Set Mats1 = .Execute(tmp)
End With
If (RegX2.Test(tmp)) Then
Set Mats1 = RegX2.Execute(tmp)
tmp = Mats1(0)
Else
With RegX2
.Pattern = "MAP\d{9}"
Set Mats1 = .Execute(tmp)
End With
If (RegX.Test(tmp)) Then
tmp = Mats1(0)
End If
End If
Set Mats1 = Nothing
Set RegX2 = Nothing
Dim tempticketnum, tmpdate As String
Dim ticketnumposition As Integer
'write them in the excel sheet
If SFrom = sassupport Then
xlSheet.Range("A" & rCount) = strColS
xlSheet.Range("B" & rCount) = tmp2
xlSheet.Range("C" & rCount) = tmp
xlSheet.Range("D" & rCount) = sFailures ' number of failures
xlSheet.Range("E" & rCount) = sMailDateReceived
rCount = rCount + 1
End If
Next
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlSheet = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
To extract the substring as you specify:
.ignorecase = True
.pattern = "map\s*(\S+)"
or
.pattern = "\bmap\s*(\S+)"
The substring will be in capturing group 1
If there is no map then the .test(..) line will return False
Regex Explained
\bmap\s*(\S+)
Options: Case insensitive; ^$ don’t match at line breaks
Assert position at a word boundary \b
Match the character string “map” literally map
Match a single character that is a “whitespace character” \s*
Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
Match the regex below and capture its match into backreference number 1 (\S+)
Match a single character that is NOT a “whitespace character” \S+
Between one and unlimited times, as many times as possible, giving back as needed (greedy) +
Created with RegexBuddy

Filter items with an email body that contains a less than symbol `<`

I'm trying to filter items with an email body that contains a less than symbol <.
Here is a sample email body that contains less than symbol.
Our drive E: is now < 10%.
Sub CodeSubjectForward(Item As Outlook.MailItem)
Dim M1 As MatchCollection
Dim M As Match
Set Reg1 = New RegExp
With Reg1
.Pattern = "([<]\s*(\w*)\s*)"
.Global = True
End With
If Reg1.Test(Item.Body) Then
Set M1 = Reg1.Execute(Item.Body)
For Each M In M1
Next
End If
Item.Save
Set myForward = Item.Forward
myForward.Recipients.Add "alias#domain.com"
myForward.Send
End Sub
Should be something like this
Public Sub FWItem(Item As Outlook.mailitem)
Dim Email As Outlook.mailitem
Dim Matches As Variant
Dim RegExp As Object
Dim Pattern As String
Set RegExp = CreateObject("VbScript.RegExp")
If TypeOf Item Is Outlook.mailitem Then
Pattern = "(\s[<]\s)"
With RegExp
.Global = False
.Pattern = Pattern
.IgnoreCase = True
Set Matches = .Execute(Item.Body)
End With
If Matches.Count > 0 Then
Debug.Print Item.subject ' Print on Immediate Window
Set Email = Item.Forward
Email.subject = Item.subject
Email.Recipients.Add "0m3r#Email.com"
Email.Save
Email.Send
End If
End If
Set RegExp = Nothing
Set Matches = Nothing
Set Email = Nothing
Set Item = Nothing
End Sub
https://regex101.com/r/KOFM8E/1/

General Purpose UDFs for using Regular Expressions in Excel

I need to parse and summarize and batches of several thousand text lines on a weekly basis. Excel wildcards weren't flexible enough, and I wanted to remove the extra step of either pasting into Notepad++ for processing or feeding to a script.
Here are the tools I came up with. They're still a bit slow -- perhaps 3000 lines per second on a company laptop -- but they are handy.
RXMatch -- return first match, option to return a subgroup.
=RXMatch("Apple","A(..)",1) -> "pp"
RXCount -- count number of matches
=RXCount("Apple","p") -> 2
RXPrint -- embed first match and/or subgroups into a template string
=RXPrint("Apple","(\S)\S+","\1 is for \0") -> "A is for Apple"
RXPrintAll -- embed each match into a template string, join the results
=RXPrintAll("Apple Banana","(\S)\S+","\1 is for \0") -> "A is for Apple, B is for Banana"
RXMatches -- return a vertical array of matches, option to return a subgroup
=RXMatches("Apple Banana","\S+") -> {"Apple";"Banana"}
RXMatch
Public Function RXMatch(Text As String, Pattern As String, Optional Group As Integer = 0, Optional IgnoreCase As Boolean = True) As String
Dim retval As String
' Takes a string and returns the matching text
' Text is the string to be searched
' Pattern is the regex pattern
' Group (optional) selects a parenthesized group (count the number of left parentheses preceding it to get the group number)
' IgnoreCase (optional) set to False for a case-sensitive search
Dim RE As Object
Dim Matches As Object
Set RE = CreateObject("vbscript.regexp")
RE.IgnoreCase = IgnoreCase
RE.Pattern = Pattern
Set Matches = RE.Execute(Text)
If (Matches.Count > 0) Then
If (Group > 0) Then
retval = Matches(0).submatches(Group - 1)
Else
retval = Matches(0)
End If
Else
retval = ""
End If
RXMatch = retval
End Function
RXCount
Public Function RXCount(Text As String, Pattern As String, Optional IgnoreCase As Boolean = True) As Integer
Dim retval As Integer
' Counts the number of matches
' Text is the string to be searched
' Pattern is the regex pattern
' IgnoreCase (optional) set to False for a case-sensitive search
Dim RE As Object
Dim Matches As Object
Set RE = CreateObject("vbscript.regexp")
RE.IgnoreCase = IgnoreCase
RE.Global = True
RE.Pattern = Pattern
Set Matches = RE.Execute(Text)
retval = Matches.Count
RXCount = retval
End Function
RXPrint
Public Function RXPrint(Text As String, Pattern As String, Optional Template As String = "\0", Optional IgnoreCase As Boolean = True) As String
Dim retval As String
' Takes a string and returns a new string formatted according to the given template, using the first match found
' Text is the string to be searched
' Pattern is the regex pattern
' Template (optional) is a string which should contain group identifiers (\0 - \9) to be substituted with groups in the match
' IgnoreCase (optional) set to False for a case-sensitive search
Dim REText, RETemplate As Object
Dim MatchesText, MatchesTemplate As Object
Set REText = CreateObject("vbscript.regexp")
REText.IgnoreCase = IgnoreCase
REText.Pattern = Pattern
Set MatchesText = REText.Execute(Text)
Set RETemplate = CreateObject("vbscript.regexp")
RETemplate.Global = True
RETemplate.Pattern = "(?:\\(.))|([^\\]+)"
Set MatchesTemplate = RETemplate.Execute(Template)
If (MatchesText.Count > 0) Then
ReDim retArray(0 To MatchesTemplate.Count - 1) As String
Dim escaped As String
Dim plaintext As String
For i = 0 To MatchesTemplate.Count - 1
escaped = MatchesTemplate(i).submatches(0)
plaintext = MatchesTemplate(i).submatches(1)
If (Len(escaped) > 0) Then
If (IsNumeric(escaped)) Then
Dim groupnum As Integer
groupnum = CInt(escaped)
If groupnum = 0 Then
retArray(i) = MatchesText(0)
ElseIf (groupnum > MatchesText(0).submatches.Count) Then
retArray(i) = "?"
Else
retArray(i) = MatchesText(0).submatches(groupnum - 1)
End If
Else
retArray(i) = escaped
End If
Else
retArray(i) = plaintext
End If
Next i
retval = Join(retArray, "")
Else
retval = ""
End If
RXPrint = retval
End Function
RXPrintAll
Public Function RXPrintAll(Text As String, Pattern As String, Optional Template As String = "\0", Optional Delimiter As String = ", ", Optional IgnoreCase As Boolean = True) As String
Dim retval As String
' Takes a string and returns a new string formatted according to the given template, repeated for each match
' Text is the string to be searched
' Pattern is the regex pattern
' Template (optional) is a string which should contain group identifiers (\0 - \9) to be substituted with groups in the match
' Delimiter (optional) specified how the results will be joined
' IgnoreCase (optional) set to False for a case-sensitive search
Dim REText, RETemplate As Object
Dim MatchesText, MatchesTemplate As Object
Set REText = CreateObject("vbscript.regexp")
REText.IgnoreCase = IgnoreCase
REText.Global = True
REText.Pattern = Pattern
Set MatchesText = REText.Execute(Text)
Set RETemplate = CreateObject("vbscript.regexp")
RETemplate.Global = True
RETemplate.Pattern = "(?:\\(.))|([^\\]+)"
Set MatchesTemplate = RETemplate.Execute(Template)
If (MatchesText.Count > 0) Then
ReDim retArrays(0 To MatchesText.Count - 1)
For j = 0 To MatchesText.Count - 1
ReDim retArray(0 To MatchesTemplate.Count - 1) As String
Dim escaped As String
Dim plaintext As String
For i = 0 To MatchesTemplate.Count - 1
escaped = MatchesTemplate(i).submatches(0)
plaintext = MatchesTemplate(i).submatches(1)
If (Len(escaped) > 0) Then
If (IsNumeric(escaped)) Then
Dim groupnum As Integer
groupnum = CInt(escaped)
If groupnum = 0 Then
retArray(i) = MatchesText(j)
ElseIf (groupnum > MatchesText(j).submatches.Count) Then
retArray(i) = "?"
Else
retArray(i) = MatchesText(j).submatches(groupnum - 1)
End If
Else
retArray(i) = escaped
End If
Else
retArray(i) = plaintext
End If
Next i
retArrays(j) = Join(retArray, "")
Next j
retval = Join(retArrays, Delimiter)
Else
retval = ""
End If
RXPrintAll = retval
End Function
RXMatches
Public Function RXMatches(Text As String, Pattern As String, Optional Group As Integer = 0, Optional IgnoreCase As Boolean = True) As Variant
Dim retval() As String
' Takes a string and returns all matches in a vertical array
' Text is the string to be searched
' Pattern is the regex pattern
' Group (optional) selects a parenthesized group (count the number of left parentheses preceding it to get the group number)
' IgnoreCase (optional) set to False for a case-sensitive search
Dim RE As Object
Dim Matches As Object
Set RE = CreateObject("vbscript.regexp")
RE.IgnoreCase = IgnoreCase
RE.Global = True
RE.Pattern = Pattern
Set Matches = RE.Execute(Text)
If (Matches.Count > 0) Then
ReDim retval(0 To Matches.Count - 1)
For i = 0 To Matches.Count - 1
If (Group > 0) Then
retval(i) = Matches(i).submatches(Group - 1)
Else
retval(i) = Matches(i)
End If
Next i
Else
ReDim retval(1)
retval(0) = ""
End If
RXMatches = Application.Transpose(retval)
End Function
When dealing with UDFs it's vital that you cache created objects.
For example:
Public Function RegexTest(ByVal vHaystack As Variant, ByVal sPattern As String, Optional ByVal sFlags As String = "") As Boolean
'If haystack is an error then return false
If IsError(vHaystack) Then Exit Function
'Stringify haystack
Dim sHaystack As String: sHaystack = vHaystack
'Cache regular expressions, especially important for formulae
Static lookup As Object
If lookup Is Nothing Then Set lookup = CreateObject("Scripting.Dictionary")
'If cached object doesn't exist, create it
Dim sKey As String: sKey = sPattern & "-" & sFlags
If Not lookup.exists(sKey) Then
'Create regex object
Set lookup(sKey) = CreateObject("VBScript.Regexp")
'Bind flags
For i = 1 To Len(sFlags)
Select Case Mid(sFlags, i, 1)
Case "i"
lookup(sKey).IgnoreCase = True
Case "g"
lookup(sKey).Global = True
End Select
Next
'Set pattern
lookup(sKey).Pattern = sPattern
End If
'Use test function of regex object
RegexTest = lookup(sKey).test(sHaystack)
End Function
Applying this to your own functions, you'll see this vastly increases the speed of execution on a large number of cells.

vbscript: replace text in activedocument with hyperlink

Starting out at a new job and I have to go through a whole lot of documents that my predecessor left. They are MS Word-files that contain information on several hundreds of patents. Instead of copy/pasting every single patent-number in an online form, I would like to replace all patent-numbers with a clickable hyperlink. I guess this should be done with vbscript (I'm not used to working with MS Office).
I have so far:
<obsolete>
This is not working for me:
1. I (probably) need to add something to loop through the ActiveDocument
2. The replace-function probably needs a string and not an object for a parameter - is there a __toString() in vbscript?
THX!
UPDATE:
I have this partially working (regex and finding matches) - now if only I could get the anchor for the hyperlink.add-method right...
Sub HyperlinkPatentNumbers()
'
' HyperlinkPatentNumbers Macro
'
Dim objRegExp, Matches, match, myRange
Set myRange = ActiveDocument.Content
Set objRegExp = CreateObject("VBScript.RegExp")
With objRegExp
.Global = True
.IgnoreCase = False
.Pattern = "(WO|EP|US)([0-9]*)(A1|A2|B1|B2)"
End With
Set Matches = objRegExp.Execute(myRange)
If Matches.Count >= 1 Then
For Each match In Matches
ActiveDocument.Hyperlinks.Add Anchor:=objRegExp.match, Address:="http://worldwide.espacenet.com/publicationDetails/biblio?DB=EPODOC&adjacent=true&locale=en_EP&CC=$1&NR=$2&KC=$3"
Next
End If
Set Matches = Nothing
Set objRegExp = Nothing
End Sub
Is this VBA or VBScript? In VBScript you cannot declare types like Dim newText As hyperLink, but every variable is a variant, so: Dim newText and nothing more.
objRegEx.Replace returns the string with replacements and needs two parameters passed into it: The original string and the text you want to replace the pattern with:
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = True
objRegEx.IgnoreCase = False
objRegEx.Pattern = "^(WO|EP|US)([0-9]*)(A1|A2|B1|B2)$"
' assuming plainText contains the text you want to create the hyperlink for
strName = objRegEx.Replace(plainText, "$1$2$3")
strAddress = objRegex.Replace(plainText, "http://worldwide.espacenet.com/publicationDetails/biblio?DB=EPODOC&adjacent=true&locale=en_EP&CC=$1&NR=$2&KC=$3"
Now you can use strName and strAddress to create the hyperlink with.
Pro-tip: You can use objRegEx.Test(plainText) to see if the regexp matches anything for early handling of errors.
Problem solved:
Sub addHyperlinkToNumbers()
Dim objRegExp As Object
Dim matchRange As Range
Dim Matches
Dim match
Set objRegExp = CreateObject("VBScript.RegExp")
With objRegExp
.Global = True
.IgnoreCase = False
.Pattern = "(WO|EP|US|FR|DE|GB|NL)([0-9]+)(A1|A2|A3|A4|B1|B2|B3|B4)"
End With
Set Matches = objRegExp.Execute(ActiveDocument.Content)
For Each match In Matches
'This doesn't work, because of the WYSIWYG-model of MS Word:
'Set matchRange = ActiveDocument.Range(match.FirstIndex, match.FirstIndex + Len(match.Value))
Set matchRange = ActiveDocument.Content
With matchRange.Find
.Text = match.Value
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Execute
End With
ActiveDocument.Hyperlinks.Add Anchor:=matchRange, _
Address:="http://worldwide.espacenet.com/publicationDetails/biblio?DB=EPODOC&adjacent=true&locale=en_EP&CC=" _
& match.Submatches(0) & "&NR=" & match.Submatches(1) & "&KC=" & match.Submatches(2)
Next
MsgBox "Hyperlink added to " & Matches.Count & " patent numbers"
Set objRegExp = Nothing
Set matchRange = Nothing
Set Matches = Nothing
Set match = Nothing
End Sub