I am trying to get all values in columns D and E which include only these with brackets - like ;;;;VariableG5>
but without these with text NEW_LINE.I found only how to extract the text between the brackets, but I want to extract it with the brackets.This is what I found:
Public Sub My_Split()
Dim z As Variant
z = Split(Replace(Join(Filter(Split(Replace(Replace(Selection.Value, "<" , ">")
Selection.Offset(0, 1).Resize(, UBound(z) + 1) = z
End Sub
Sub simpleRegex()
Dim strPattern As String: strPattern = " <([a-z] | [A-Z] | [0-9] | \. | - | _)+>"
Dim Match As Object
Dim matches As Object
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
Dim strInput As String
Dim Myrange As Range
Set Myrange = ActiveSheet.Range("D8:D10")
For Each cell In Myrange
If strPattern <> "" Then
strInput = cell.Value
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = strPattern
End With
If regex.Test(strInput) Then
Set matches = regex.Execute(strInput)
For Each Match In matches
MsgBox (Match.Value) 'A workaround I found to see if my pattern
'worked but I need to print Match.value
'in a column so this wont do
Next
Else
MsgBox ("Not matched")
End If
End If
Next
End Sub
Related
how can I get in VBA a complex string in a substring, e.g. if i = InStr("test-VBA", " this is a test") then msgbox "a part of searching Item exist"
with function "Instr" didn't work because the seraching word is "test-VBA" and ofcourse dosen't
exist as a one word but what I search for if a complete part of the searching item ("test" in the
example as part of "test-VBA") exists should I get a msgbox like described above
Thanks a lot.
Function IsInStr_IgnoreCase(ByVal Str As String, ByVal Value As String) As Boolean
Dim objRegEx as Object
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.pattern = Value
IsInStr_IgnoreCase = objRegEx.test(Str) ' objRegEx.test(Str) returns True if Sustr exists.
End Function
Sub test()
' this returns TRUE if you get a match
MsgBox IsInStr_IgnoreCase_AsBoolean("CHINA-Country", "Move the dev from China to Newseeland")
' this returns all matches of 'Value' in 'Str'
MsgBox IsInStr_IgnoreCase_AsString("CHINA-Country", "Move the dev from China to Newseeland")
' you need to adjust objRegEx.Pattern if you need to get a specific match. See RegEx.
End Sub
Function IsInStr_IgnoreCase_AsBoolean(ByVal Value As String, ByVal Value As String) As Boolean
Dim objRegEx As Object
Dim tStr, tVal, iStr, iVal
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = True
objRegEx.Pattern = "(\b\w+)|(\b\d+)"
Set tStr = objRegEx.Execute(Str)
Set tVal = objRegEx.Execute(Value)
objRegEx.IgnoreCase = True
For Each iStr In tStr
For Each iVal In tVal
objRegEx.Pattern = iVal
If objRegEx.test(iStr) Then
IsInStr_IgnoreCase_AsBoolean = True
Exit Function
End If
Next
Next
End Function
Function IsInStr_IgnoreCase_AsString(ByVal Str As String, ByVal Value As String) As String
Dim objRegEx As Object
Dim tStr, tVal, iStr, iVal
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = True
objRegEx.Pattern = "(\b\w+)|(\b\d+)"
Set tStr = objRegEx.Execute(Str)
Set tVal = objRegEx.Execute(Value)
objRegEx.IgnoreCase = True
For Each iStr In tStr
For Each iVal In tVal
objRegEx.Pattern = iVal
If objRegEx.test(iStr) Then
IsInStr_IgnoreCase_AsString = IsInStr_IgnoreCase_AsString & iStr & "; "
End If
Next
Next
End Function
I have a large number of documents which I need to pull out file name references from, spread out across large blocks of text and footnotes.
I currently have a word VBA code that I think should search for a string (for example "This_") and then the following # of characters, and then paste them into a waiting excel sheet. I am struggling to get it to search both the footnotes and the main body of text.
I've been using the code below, but my work at the moment is making it do something weird. It will find the string I am searching for, but then it will copy from the start of the document the number of times the string has been found -- not the string and its subsequent text.
Any help would be appreciated in modifying this, I believe the issue will be coming from the first half of the 'return data to array section.
Option Explicit
Option Base 1
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
If IsWindowsOS Then
Tgt = "C:\users\user\" & TgtFile ' Windows OS
Else
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.workbooks.Open(Tgt)
Set mySh = myWB.sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
Public Function IsWindowsOS() As Boolean
If Application.System.OperatingSystem Like "*Win*" Then
IsWindowsOS = True
Else
IsWindowsOS = False
End If
End Function
Your code is a little confused as there is an unholy mix of Selection and Range. It is good practice to avoid using Selection as it is very rarely necessary to select anything when working in VBA.
VBA also has compiler constants that can be used to detect, among other things, whether code is being run on a Mac. Not sure if the Mac constant still works reliably as I no longer have one to test on.
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
'This isn't necessary as there is a compiler constant that can be used to identify code is running on Mac
' If IsWindowsOS Then
' Tgt = "C:\users\user\" & TgtFile ' Windows OS
' Else
' Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
' End If
#If Mac Then
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
#Else
Tgt = "C:\users\user\" & TgtFile ' Windows OS
#End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
'not necessary to select the story range
'ActiveDocument.StoryRanges(wdFootnotesStory).Select
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
End With
While .Find.Execute
'a match has been found and oRng redefined to the range of the match
i = i + 1
.MoveEnd wdCharacter, Lgth
arr(i) = .Text
.Collapse wdCollapseEnd
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
For example, the following code returns both the found text and its page reference:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrFnd As String, StrOut As String
StrFnd = InputBox("String to find")
j = InputBox("String Length to find")
k = j - Len(StrFnd)
For i = 1 To k
StrFnd = StrFnd & "^?"
Next
With ActiveDocument
For i = 1 To 2 ' 1 = wdMainTextStory, 2 = wdFootnotesStory, 3 = wdEndnotesStory, etc.
With .StoryRanges(i)
With .Find
.ClearFormatting
.Text = StrFnd
.Forward = True
.Format = True
.MatchWildcards = False
.Wrap = wdFindStop
.Replacement.Text = ""
End With
Do While .Find.Execute = True
StrOut = StrOut & vbCr & .Text & vbTab
Select Case .StoryType
Case wdMainTextStory
StrOut = StrOut & .Information(wdActiveEndAdjustedPageNumber)
Case wdFootnotesStory
StrOut = StrOut & .Duplicate.Footnotes(1).Reference.Information(wdActiveEndAdjustedPageNumber)
End Select
Loop
End With
Next
End With
MsgBox StrOut
Application.ScreenUpdating = True
End Sub
This is an example of how to search multiple section of your document. Note that I'm using a Collection to gather up the items, so you don't have to keep increasing an array.
Option Explicit
Option Base 1
Sub test()
Dim allFound As Collection
Set allFound = TextFoundReport("This_", 10)
Dim entry As Variant
For Each entry In allFound
Dim partType As Long
Dim text As String
Dim tokens() As String
tokens = Split(entry, "|")
'--- here is where you copy to an Excel sheet
Debug.Print "Part type: " & tokens(0) & " - '" & tokens(1) & "'"
Next entry
End Sub
Private Function TextFoundReport(ByVal text As String, _
ByVal numberOfCharacters As Long) As Collection
Dim whatWeFound As Collection
Set whatWeFound = New Collection
'--- create a list of the document parts to search
Dim docParts As Variant
docParts = Array(wdMainTextStory, wdFootnotesStory, wdEndnotesStory, wdCommentsStory)
Dim foundRng As Range
Dim docPart As Variant
For Each docPart In docParts
ActiveDocument.StoryRanges(docPart).Select
'--- find all occurences in this part and add it to the collection
' the Item in the collection is the story type and the found text
With Selection.Find
.ClearFormatting
.Forward = True
.text = text
.MatchCase = True
.Execute
Do While .found
Set foundRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Len(text), _
End:=Selection.Range.End + numberOfCharacters)
whatWeFound.Add CLng(docPart) & "|" & foundRng.text
foundRng.Start = foundRng.End
.Execute
Loop
End With
Next docPart
Set TextFoundReport = whatWeFound
End Function
Question with a possibly very simple answer, but I'm still potty training with VBA. I'm looping through an excel array and searching a very long string for the regex pattern "\.\w*?_\w*?_Tag_\w*?". There is a similar example of this in this post under the accepted answer "Example 3: Loop Through Range."
Instead of finding and replacing text though, I want to display the matched search pattern from each cell of the array in a single message box. I've been searching for several hours but most of the VBA Regex examples I've found use built in functions (which don't loop through an array), but since this will be used by other folks I need to use a macro.
Here's what I have so far. I'm thinking I need another loop outside of my For Each loop but not sure how to start executing on this.
Sub TagNameList()
Dim strPattern As String: strPattern = "\.\w*?_\w*?_Tag_\w*?"
Dim Regx As New RegExp
Dim StrInput As String
Dim Rng As range
Dim LastRow As Long: LastRow = ActiveSheet.UsedRange.Rows.Count
' Set Rng = ActiveSheet.range(Cells(2, 16), Cells(LastRow, 16))
' Set RegxMatch = Regx.Execute(StrInput)
For Each cell In Rng
StrInput = cell.Value
With Regx
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = strPattern
End With
' If Regx.Test(StrInput) Then
' MsgBox (Regx.Replace(StrInput, strReplace))
' Else
' MsgBox ("Not matched")
' End If
Next
End Sub
I'm not clear if you mean a message box for the whole range or one for each cell, but you need to use the matches collection, e.g.
Sub TagNameList()
Dim strPattern As String: strPattern = "\.\w*?_\w*?_Tag_\w*?"
Dim Regx As New RegExp
Dim StrInput As String
Dim Rng As Range
Dim LastRow As Long: LastRow = ActiveSheet.UsedRange.Rows.Count
Dim oMatches As Object, s As String
Set Rng = ActiveSheet.Range(Cells(2, 16), Cells(LastRow, 16))
Set RegxMatch = Regx.Execute(StrInput)
For Each cell In Rng
StrInput = cell.Value
With Regx
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = strPattern
If .Test(cell) Then
Set oMatches = .Execute(cell)
s = s & "," & oMatches(0).Value
End If
End With
Next
MsgBox Mid(s, 2)
End Sub
I try create new function in Excel, witch will counting given values (something like SUM function, but only with given prefix).
A
---------
1|AA30
2|AA10
3|BC446
4|AA10
// result will be 50 on SUM_PREFIX(A1:A4;"AA")
Problem is, when the value is in the form e.g AA10,434 or AA4.43. Could me anyone help me with my problem? This is my first stript in VB.
Function SUM_PREFIX(Data As Range, prefix As String) As Double
Dim result As Double
Dim strVal As String
Dim i As Integer
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.IgnoreCase = True
.MultiLine = False
.Pattern = "^[" + prefix + "]+[0-9]+(\,|\.)?[0-9]?$"
.Global = True
End With
For i = 1 To Data.Rows.Count
Debug.Print Data.Cells(i, 1)
If objRegExp.Test(Data.Cells(i, 1)) = True Then
strVal = Replace(Data.Cells(i, 1), prefix, "")
Debug.Print strVal
strVal = Trim(Replace(strVal, ",", "."))
Debug.Print strVal
result = result + CDbl(strVal)
End If
Next i
SUM_PREFIX = result
End Function
Thanks for help.
CDbl is locale-aware, so check if your Replace is correct (for example, in my locale, I have to replace "." by "," in order for it to work).
If you don't want to rely on locale-aware code, use Val instead of CDbl because Val only recognizes "." as a valid decimal separator regardless of locale.
Function SUM_PREFIXO(DADOS As Range, PREFIXO As String) As Double
Dim result, NI As Double
Dim strVal As String
Dim i As Integer
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.IgnoreCase = True
.MultiLine = False
.Pattern = "^[" + PREFIXO + "]+[0-9]+(\,|\.)?[0-9]?$"
.Global = True
End With
NI = DADOS.Rows.Count
For i = 1 To DADOS.Rows.Count
Debug.Print (DADOS.Cells(i, 1))
If objRegExp.Test(RetiraEspaço(DADOS.Cells(i, 1))) = True Then
strVal = Trim(Replace(DADOS.Cells(i, 1), PREFIXO, ""))
Debug.Print strVal
strVal = Trim(Replace(strVal, ".", ","))
Debug.Print strVal
strVal = Trim(Replace(strVal, ",", ","))
Debug.Print strVal
result = result + CDbl(strVal)
End If
Next i
SUM_PREFIXO = result
End Function
'Com o código abaixo pode-se
'remover os espaços extras entre as palavras de um texto:
Function RetiraEspaço(Texto)
Dim Vpalavra, inicio, termino, Wresultado
inicio = 1
Texto = UCase(Texto) & " "
Do Until InStr(inicio, Texto, " ") = 0
termino = InStr(inicio, Texto, " ")
Vpalavra = Mid(Texto, inicio, termino - inicio)
inicio = termino + 1
Wresultado = Wresultado & "" & Vpalavra
Loop
RetiraEspaço = Trim(Wresultado)
End Function
I have a VBA macro for Microsoft Word that I am trying to improve.
The purpose of the macro is to bold and italicize all words in a document that match the search terms in the first table of the document.
The problem is the search terms include wildcards which are the following:
the hyphen "-": between letters a wildcard for either a space or a period
asterisk "&": (the site is not letting me put in asterisks as this is the markdown for italicize, so I'll put in the & symbol instead to get around the filters) a wildcard for any number of characters at the beginning of a word or at the end. Unlike normal programming languages though, when it is used in the middle of the word it needs to be combined with the hyphen to be a wildcard for a range of characters. For example "th&-e" would pick up "there" while "th&e" would not.
question mark "?": wildcard for a single character
What I am doing so far is just testing for these characters and if they are present I either lop them off in the case of the asterisk, or I alert the user that they have to search for the word manually. Not ideal :-P
I have tried the .MatchWildcard property in VBA but have not yet gotten it to work. I have a feeling it has something to do with the replacement text, not the search text.
A working macro will take the following as its input (the first row is intentionally ignored and the second column is the one with the target search terms):
Imagine this in a table all in the second column (as the html allowed here doesn't allow tr and td etc)
First row: Word
Second row: Search
Third row: &earch1
Fourth row: Search2&
Fifth row: S-earch3
Sixth row: S?arch4
Seventh row: S&-ch5
And it will search the document and replace with bold and italicized content like so:
Search Search1 Search2 Search3 Search4 Search5
Note: S-earch3 could also pick up S.earch3 and replace with Search3
As one might assume the search terms will usually not be right next to each other - the macro should find all instances.
I will include my attempted but nonfunctional code as well after the first working macro.
The code for the working macro will be on pastebin for a month from today, which is 9/17/09, at the following url.
Thanks again for any thoughts and help you might have to offer!
Sara
Working VBA Macro:
Sub AllBold()
Dim tblOne As Table
Dim celTable As Cell
Dim rngTable As Range
Dim intCount As Integer
Dim celColl As Cells
Dim i As Integer
Dim rngLen As Integer
Dim bolWild As Boolean
Dim strWild As String
Set tblOne = ActiveDocument.Tables(1)
intCount = tblOne.Columns(2).Cells.Count
Set celColl = tblOne.Columns(2).Cells
strWild = ""
For i = 1 To intCount
If i = 1 Then
i = i + 1
End If
Set celTable = ActiveDocument.Tables(1).Cell(Row:=i, Column:=2)
Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _
End:=celTable.Range.End - 1)
rngLen = Len(rngTable.Text)
bolWild = False
If (Mid(rngTable.Text, rngLen, 1) = "&") Then 'remember to replace & with asterisk!'
rngTable.SetRange Start:=rngTable.Start, End:=rngTable.End - 1
End If
If (Mid(rngTable.Text, 1, 1) = "&") Then 'remember to replace & with asterisk!'
rngTable.SetRange Start:=rngTable.Start + 1, End:=rngTable.End
End If
If InStr(1, rngTable.Text, "-", vbTextCompare) > 0 Then
strWild = strWild + rngTable.Text + Chr$(13)
bolWild = True
End If
If InStr(1, rngTable.Text, "?", vbTextCompare) > 0 Then
strWild = strWild + rngTable.Text + Chr$(13)
bolWild = True
End If
If (bolWild = False) Then
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Text = rngTable.Text
With .Replacement
.Text = rngTable.Text
.Font.Bold = True
.Font.Italic = True
End With
.Execute Replace:=wdReplaceAll
End With
End If
Next
If bolWild = True Then
MsgBox ("Please search the following strings with - or ? manually:" + Chr$(13) + strWild)
End If
End Sub
Attempted Nonfunctional VBA Macro:
Sub AllBoldWildcard()
Dim tblOne As Table
Dim celTable As Cell
Dim rngTable As Range
Dim intCount As Integer
Dim celColl As Cells
Dim i As Integer
Dim rngLen As Integer
Dim bolWild As Boolean
Dim strWild As String
Dim strWildcard As String
Set tblOne = ActiveDocument.Tables(1)
intCount = tblOne.Columns(2).Cells.Count
Set celColl = tblOne.Columns(2).Cells
strWild = ""
For i = 1 To intCount
If i = 1 Then
i = i + 1
End If
Set celTable = ActiveDocument.Tables(1).Cell(Row:=i, Column:=2)
Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _
End:=celTable.Range.End - 1)
rngLen = Len(rngTable.Text)
bolWild = False
If (Mid(rngTable.Text, 1, 1) = "&") Then 'remember to replace & with asterisk!'
rngTable.SetRange Start:=rngTable.Start + 1, End:=rngTable.End
End If
If InStr(1, rngTable.Text, "&", vbTextCompare) > 0 Then 'remember to replace & with asterisk!'
strWildcard = rngTable.Text
rngTable.Text = Replace(rngTable.Text, "&", "", 1) 'remember to replace & with asterisk!'
bolWild = True
End If
If InStr(1, rngTable.Text, "-", vbTextCompare) > 0 Then
strWildcard = Replace(rngTable.Text, "-", "[.-]", 1)
bolWild = True
End If
If InStr(1, rngTable.Text, "?", vbTextCompare) > 0 Then
strWild = strWild + rngTable.Text + Chr$(13)
strWildcard = Replace(rngTable.Text, "?", "_", 1)
bolWild = True
End If
If (bolWild = False) Then
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
With oRng.Find
.ClearFormatting
.Text = strWildcard
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
With .Replacement
.Text = rngTable.Text
.Font.Bold = True
.Font.Italic = True
End With
.Execute Replace:=wdReplaceAll
End With
End If
Next
' If bolWild = True Then'
' MsgBox ("Please search the following strings with - or ? manually:" + Chr$(13) + strWild)'
' End If'
End Sub
Maybe the LIKE statement could help you:
if "My House" like "* House" then
end if
Regular Expressions:
Searching for Search4 and replace it by SEARCH4 and using wildcards to achieve that:
Set objRegEx = CreateObject("vbscript.regexp")
objRegEx.Global = True
objRegEx.IgnoreCase = True
objRegEx.MultiLine = True
'here you can enter your search with wild cards
'mine says "S" followed by any character followed by "arch" followed by 1-n numbers.
objRegEx.Pattern = "S.arch([0-9]+)"
newText = objRegEx.Replace("Test Search4", "SEARCH$1")
MsgBox (newText)
'gives you: Test SEARCH4
More information how those wildcards to use can be found here
It might be hard in the beginning but I promise you will love it ;)
You can replace use to search for strings too:
Dim text As String
text = "Hello Search4 search3 sAarch2 search0 search"
Set objRegEx = CreateObject("vbscript.regexp")
objRegEx.Global = True
objRegEx.IgnoreCase = True
objRegEx.MultiLine = True
'here you can enter your search with wild cards
'mine says "S" followed by any character followed by "arch" followed by 1-n numbers.
objRegEx.Pattern = "S.arch[0-9]+"
If (objRegEx.test(text) = True) Then
Dim objMatch As Variant
Set objMatch = objRegEx.Execute(text) ' Execute search.
Dim wordStart As Long
Dim wordEnd As Long
Dim intIndex As Integer
For intIndex = 0 To objMatch.Count - 1
wordStart = objMatch(intIndex).FirstIndex
wordEnd = wordStart + Len(objMatch(intIndex))
MsgBox ("found " & objMatch(intIndex) & " position: " & wordStart & " - " & wordEnd)
Next
End If
The result for the variable text would be:
Search4 position: 6 - 13
Search3 position: 14- 21
...
So in your code you would use
rngTable.Text as text
and
rngTable.SetRange Start:=rngTable.Start + wordStart, End:=rngTable.Start + wordEnd
would be the range you want to set bold.
Sub AllBold()
Dim tblOne As Table
Dim celTable As Cell
Dim rngTable As Range
Dim intCount As Integer
Dim intMatch As Integer
Dim celColl As Cells
Dim i As Integer
Dim strRegex As String
Dim Match, Matches
Set tblOne = ActiveDocument.Tables(1)
intCount = tblOne.Columns(2).Cells.Count
Set celColl = tblOne.Columns(2).Cells
Set objRegEx = CreateObject("vbscript.regexp")
objRegEx.Global = True
objRegEx.IgnoreCase = True
objRegEx.MultiLine = True
For i = 1 To intCount
If i = 1 Then
i = i + 1
End If
Set celTable = ActiveDocument.Tables(1).Cell(Row:=i, Column:=2)
Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _
End:=celTable.Range.End - 1)
If rngTable.Text <> "" Then
strRegex = rngTable.Text
strRegex = Replace(strRegex, "*-", "[\w]{0,}[^\w]{0,1}[\w]{0,}", 1)
strRegex = Replace(strRegex, "*", "\w+", 1)
strRegex = Replace(strRegex, "-", "[^\w]{0,1}", 1)
strRegex = Replace(strRegex, "?", ".", 1)
objRegEx.Pattern = "\b" + strRegex + "\b"
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
Set Matches = objRegEx.Execute(ActiveDocument.Range.Text)
intMatch = Matches.Count
If intMatch >= 1 Then
rngTable.Bold = True
For Each Match In Matches
With oRng.Find
.ClearFormatting
.Text = Match.Value
With .Replacement
.Text = Match.Value
.Font.Bold = True
.Font.Italic = True
End With
.Execute Replace:=wdReplaceAll
End With
Next Match
End If
End If
Next i
End Sub