Converting String to Double in Excel / Macro - vba

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

Related

find a complex string in a substring in VBA

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

Get all substrings with brackets "<" and ">" in vba

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

Optimizing the Vba code

There is a program ,that parsing website . Program works well , but too long . I want to simplify/speed it up. Tell me please ,maybe there are any specialized sites on this issue ? For any help I will be grateful .
How program works:
First , by the hyperlink , the program goes to the site , where it finds a certain table of elements
Then it takes out the “href” of each element , turns it into a hyperlink , and inserts it into Excel in the 1-st table
Then it extracts the text of each element and inserts it into Excel in the 2-nd table
Then it goes through the elements of the 1-st and 2-nd tables , so that in the 3-rd table each element contains a “hyperlink +text”
Sub Softгиперссылки()
Application.DisplayAlerts = False
Call mainмассивы
Application.DisplayAlerts = True
End Sub
Sub mainмассивы()
Dim r As Range
Dim firstAddress As String
Dim iLoop As Long
Dim book1 As Workbook
Dim sheetNames(1 To 19) As String
Dim Ssilka As String
sheetNames(1) = "Лист1"
sheetNames(2) = "Лист2"
sheetNames(3) = "Лист3"
sheetNames(4) = "Лист4"
sheetNames(5) = "Лист5"
sheetNames(6) = "Лист6"
sheetNames(7) = "Лист7"
sheetNames(8) = "Лист8"
sheetNames(9) = "Лист9"
sheetNames(10) = "Лист10"
sheetNames(11) = "Лист11"
sheetNames(12) = "Лист12"
sheetNames(13) = "Лист13"
sheetNames(14) = "Лист14"
sheetNames(15) = "Лист15"
sheetNames(16) = "Лист16"
sheetNames(17) = "Лист17"
sheetNames(18) = "Лист18"
sheetNames(19) = "Лист19"
'пропускаем ошибку
Set book1 = Workbooks.Open("E:\Super M\Проект ставки\Поиск решения\Усов 7\Условия для андердогов\6.xlsm")
iLoop = -1
With book1.Worksheets("Лист1").Range("R34:R99")
For Each r In .Rows
If r.Value = 1 Then
iLoop = iLoop + 1
Ssilka = r.Offset(, -13).Hyperlinks.Item(1).Address
.Parent.Parent.Worksheets(sheetNames(1)).Activate
.Parent.Parent.Save
extractTable Ssilka, book1, iLoop
End If
Next r
End With
book1.Save
book1.Close
Exit Sub
End Sub
Function extractTable(Ssilka As String, book1 As Workbook, iLoop As Long)
Dim oDom As Object, oTable As Object, oRow As Object
Dim iRows As Integer, iCols As Integer
Dim x As Integer, y As Integer
Dim data()
Dim oHttp As Object
Dim oRegEx As Object
Dim sResponse As String
Dim oRange As Range
Dim Perem1 As String
Dim Perem2 As String
'для гиперссылки
' get page
Set oHttp = CreateObject("MSXML2.XMLHTTP")
oHttp.Open "GET", Ssilka, False
oHttp.Send
' cleanup response
sResponse = StrConv(oHttp.responseBody, vbUnicode)
Set oHttp = Nothing
sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
.MultiLine = True
.Global = True
.IgnoreCase = False
.Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
sResponse = .Replace(sResponse, "")
End With
Set oRegEx = Nothing
' create Document from response
Set oDom = CreateObject("htmlFile")
oDom.Write sResponse
DoEvents
' table with results, indexes starts with zero
Set oTable = oDom.getelementsbytagname("table")(3)
DoEvents
iRows = oTable.Rows.Length
iCols = oTable.Rows(1).Cells.Length
' first row and first column contain no intresting data
ReDim data(1 To iRows - 1, 1 To iCols - 1)
' fill in data array
For x = 1 To iRows - 1
Set oRow = oTable.Rows(x)
For y = 1 To iCols - 1
If oRow.Cells(y).Children.Length > 0 Then
data(x, y) = oRow.Cells(y).getelementsbytagname("a")(0).getattribute("href")
End If
Next y
Next x
Set oRow = Nothing
Set oTable = Nothing
Set oDom = Nothing
' put data array on worksheet
Set oRange = book1.ActiveSheet.Cells(110, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
oRange.NumberFormat = "#"
oRange.Value = data
oRange.Replace What:="about:", Replacement:="http://allscores.ru/soccer/"
Set oRange = Nothing
'!!!! для текста
' get page
Set oHttp = CreateObject("MSXML2.XMLHTTP")
oHttp.Open "GET", Ssilka, False
oHttp.Send
' cleanup response
sResponse = StrConv(oHttp.responseBody, vbUnicode)
Set oHttp = Nothing
sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
.MultiLine = True
.Global = True
.IgnoreCase = False
.Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
sResponse = .Replace(sResponse, "")
End With
Set oRegEx = Nothing
' create Document from response
Set oDom = CreateObject("htmlFile")
oDom.Write sResponse
DoEvents
' table with results, indexes starts with zero
Set oTable = oDom.getelementsbytagname("table")(3)
DoEvents
iRows = oTable.Rows.Length
iCols = oTable.Rows(1).Cells.Length
' first row and first column contain no intresting data
ReDim data(1 To iRows - 1, 1 To iCols - 1)
' fill in data array
For x = 1 To iRows - 1
Set oRow = oTable.Rows(x)
For y = 1 To iCols - 1
If oRow.Cells(y).Children.Length > 0 Then
data(x, y) = oRow.Cells(y).innerText
End If
Next y
Next x
Set oRow = Nothing
Set oTable = Nothing
Set oDom = Nothing
' put data array on worksheet
Set oRange = book1.ActiveSheet.Cells(185, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
oRange.NumberFormat = "#"
oRange.Value = data
Set oRange = Nothing
'!!!!! цикл для текст+гиперссылка
For A = 0 To 4
For B = 0 To 65
Perem1 = book1.ActiveSheet.Cells(110 + B, (26 + (iLoop * 21)) + A).Value
Perem2 = book1.ActiveSheet.Cells(185 + B, (26 + (iLoop * 21)) + A).Value
book1.ActiveSheet.Hyperlinks.Add Anchor:=Cells(34 + B, (26 + (iLoop * 21)) + A), Address:=Perem1, TextToDisplay:=Perem2
Next
Next
End Function
There are number of things that could be done to improve efficiency, but that is probably better conducted on CodeReview.
I will make mention, however, of your use of late-bound variables. You'll achieve much faster performance with early-binding:
'Late-bound variable declaration and creation
Dim oRegExp As Object
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
'....
End With
'Late-bound reference only:
'No variable declaration required, the variable only survives as long as the With Block
With CreateObject("vbscript.regexp")
'....
End With
'Early-bound - Add a reference to Microsoft VBScript Regular Expressions 5.5
'This is the fastest and most efficient use of a new RegExp object, and you get intellisense in the VBE
With New RegExp
'....
End With
You should also consider installing the free, open-source Rubberduck VBA add-in for the Visual Basic Editor (disclaimer - I'm a contributor), which will come with many more suggestions and optimizations for you, and it will automatically indent your code for improved readability.

Extract text from string starting and ending by specific char

I've got the code below which is extracting a string from brackets and it's ok, but now I've found out that sometimes in my string there can be more brackets with texts behind and I need to extract them too. For instance, a list or table.
e.g
hsus(irt)bla dsd (got)(rifk)
I need then: irt, got, rifk to list, how to do it?
Public Function extract_value(str As String) As String
dim str as string
dim openPos as integer
dim closePos as integer
dim midBit as string
str = "sometinhf(HELLO)sds"
openPos = instr (str, "(")
closePos = instr (str, ")")
midBit = mid (str, openPos+1, closePos - openPos - 1)
End Function
Sub Main()
Dim s$
s = "hsus(irt)bla dsd (got)(rifk)"
Debug.Print extract_value(s)
End Sub
Public Function extract_value$(s$)
Dim returnS$
Dim v
v = Split(s, Chr(40))
For Each Item In v
If InStr(Item, Chr(41)) Then
returnS = returnS & Chr(32) & Split(Item, ")")(0)
End If
Next
extract_value = Trim$(returnS)
End Function
You can use a Regexp to extract the matching strings directly
Sub Main()
Dim strTest as string
strTest = "hsus(irt)bla dsd (got)(rifk)"
MsgBox GrabIt(strTest)
End Sub
Function GrabIt(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\((.*?)\)"
.Global = True
If .test(strIn) Then
Set objRegMC = .Execute(strIn)
For Each objRegM In objRegMC
GrabIt = GrabIt & Chr(32) & objRegM.submatches(0)
Next
End If
End With
End Function

Getting wildcards to work in find and replace function in VBA macro for Microsoft Word

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