I have a macro as follows:
Sub CommentOutParenthsLocal()
'
' CommentBubble Macro
'
'
Dim myRange As Range
Set myRange = Selection.Range
Set oScope = myRange.Duplicate
searchText = "\(*\)"
With myRange.Find
.MatchWildcards = True
Do While .Execute(findText:=searchText, Forward:=True) = True
If myRange.InRange(oScope) Then
If Len(myRange.Text) > 4 Then
ActiveDocument.Comments.Add myRange, myRange.Text
myRange.Text = ""
End If
Else
Exit Do
End If
Loop
End With
End Sub
However, this doesn't work if I have nested parenthesis for example This is my (nested parenthesis (document ) in full)
It will match to the first right parenthesis not the outermost. Is there a way to write a regular expression where it matches?
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With Selection
Set Rng = .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "\([!\(]#\)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If Not .InRange(Rng) Then Exit Do
If Len(.Text) > 4 Then
.Comments.Add .Range, .Text
.Text = ""
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
As advice, please try to use Option Explicit at the start of every Module/Class/Form. This will prevent you from using variables that you haven't declared.
The code below will reduce
This is my (nested parenthesis (document ) in full)
To
This is my
with
(nested parenthesis (document ) in full)
added as a comment.
Option Explicit
Sub CommentOutParenthsLocal()
'
' CommentBubble Macro
'
'
Dim myRange As Range
Set myRange = Selection.Range
Dim oScope As Word.Range
Set oScope = myRange.Duplicate
Dim searchtext As String
searchtext = "\(*\)"
With myRange.Find
.MatchWildcards = True
Do While .Execute(findText:=searchtext, Forward:=True) = True
myRange.Select
If myRange.InRange(oScope) Then
Dim myCount As Long
Dim myText As String
myText = myRange.Text
myCount = Len(myText) - Len(Replace(myText, "(", vbNullString)) - 1
Do Until myCount = 0
myRange.MoveEndUntil cset:=")"
myRange.MoveEnd Count:=1
myCount = myCount - 1
Loop
If Len(myRange.Text) > 4 Then
ActiveDocument.Comments.Add myRange, myRange.Text
myRange.Text = ""
End If
Else
Exit Do
End If
myRange.Start = myRange.End + 1
myRange.End = oScope.End
Loop
End With
End Sub
Related
I want to round numbers embedded in text in a selection in Word. Unlike many solutions for rounding on the net, the values are not isolated in table cells etc. but may be in the text and have additional characters around them.
Examples: 0.0044***, (0.0040–0.0047) +/-0.0012.
I adapted the following code from this post which was designed to round to whole numbers:
Sub RoundNumbers()
Dim OrigRng As Range
Dim WorkRng As Range
Dim FindPattern As String
Dim FoundVal As String
Dim decplace as Integer
Set OrigRng = Selection.Range
Set WorkRng = Selection.Range
FindPattern = "([0-9]){1,}.[0-9]{1,}"
decplace = 3
Do
With WorkRng
.SetRange OrigRng.Start, OrigRng.End ' using "set WorkRng = OrigRng" would cause them to point to the same object (OrigRng is also changed when WorkRng is changed)
If .Find.Execute(findtext:=FindPattern, Forward:=True, _
MatchWildcards:=True) Then
.Expand wdWord ' I couldn't find a reliable way for greedy matching with Word regex, so I expand found range to word
.Text = FormatNumber(Round(CDbl(.Text) + 0.000001, decplace), decplace, vbTrue)
End If
End With
Loop While WorkRng.Find.Found
End Sub
I thought I could extend the Round function to round to a specified number of decimals, e.g. .Text = round(CDbl(.Text) + 0.000001, 3).
The problem with this is that the macro continues to find the first value in the selection and doesn't move to subsequent numbers. Presumably this is because, unlike the whole numbers, the rounded values still match the regex.
A solution suggested was to replace the count of digits post decimal from one or more {1,} with a fixed value e.g., {4}. This works if all the values to be rounded have the same format but doesn't have the flexibility I need.
So how can I get it to move to the next value? Alternatively, does anyone have a better solution?
For example, to process a whole document:
Sub DemoA()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "<[0-9]#.[0-9]#>"
End With
Do While .Find.Execute = True
.Text = Format(.Text, "0.000")
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
or to process just a selected range:
Sub DemoB()
Application.ScreenUpdating = False
Dim Rng As Range
With Selection
Set Rng = .Range
.Collapse wdCollapseStart
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "<[0-9]#.[0-9]#>"
End With
Do While .Find.Execute = True
If .InRange(Rng) = False Then Exit Do
.Text = Format(.Text, "0.000")
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
I think the issue you have is that you are not changing the range to reflect the text left to search. You seem to be resetting to the start of the range each time.
The following code may help
Option Explicit
Public Sub RoundNumbers(ByVal ipRange As wordRange)
Dim myRange As Word.Range
If ipRange Is Nothing Then
Set myRange = ActiveDocument.StoryRanges(wdMainTextStory)
Else
Set myRange = ipRange.Duplicate
End If
Dim myPreservedRangeEnd As Long
myPreservedRangeEnd = myRange.End
Dim myFindPattern As String
myFindPattern = "[0-9]{1,}.[0-9]{1,}"
Dim myDecplace As Long
myDecplace = 3
Do
Set myRange = FindWildCardPattern(myRange, myFindPattern)
If myRange Is Nothing Then
Exit Do
End If
myRange.Text = FormatNumber(Round(CDbl(myRange.Text) + 0.000001, myDecplace), myDecplace, vbTrue)
' At this point myRange is the newly inserted text so to search
' the remainder of the text in the selection we need to move
' the start to after the current range and replace the end of the
' current range with the preserved end of the selection range
myRange.Start = myRange.End + 1
myRange.End = myPreservedRangeEnd
Loop
End Sub
Public Function FindWildCardPattern(ByVal ipRange As Range, ipFindPattern As String) As Range
If ipRange Is Nothing Then
Set ipRange = ActiveDocument.StoryRanges(wdMainTextStory)
End If
With ipRange
With .Find
.Text = ipFindPattern
.Forward = True
.MatchWildcards = True
.Execute
End With
If .Find.Found Then
Set FindWildCardPattern = .Duplicate
Else
Set FindWildCardPattern = Nothing
End If
End With
End Function
The essential problem in your code is that you have the loop in the wrong place, and you set WordRng back to the beginning with each loop. Absent any example text I used the text in your question to test. The following should work:
Sub RoundNumbers()
Dim WorkRng As Range: Set WorkRng = Selection.Range
Dim FindPattern As String: FindPattern = "([0-9]){1,}.[0-9]{1,}"
Dim FoundVal As String
Dim decplace As Integer
decplace = 3
With WorkRng
With .Find
.ClearFormatting
.Text = FindPattern
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
.Text = FormatNumber(Round(CDbl(.Text) + 0.000001, decplace), decplace, vbTrue)
Loop
End With
End Sub
I have a word document that has SQL code in it. I have great code that finds specific terms I didn't realize that I had so many different terms in my document. I stopped at over 140 terms. I tried to add regex but I did it wrong. Would it be possible to have it find the start word SELECT and the end word FROM and change the background color to wdBrightGreen for everything between those terms?
I did not put all the fields in I stopped at three. Is there a way to put the ArrFind to search the whole document instead of specific terms?
Dim ArrFnd As Variant
Dim i As Long
Dim x As Long
Dim y As Long
Dim regexObject As RegExp
Dim strField1(1 To 200) As String
Dim strField2(1 To 20) As String
strField1(1) = "SELECT DISTINCT policy_id"
strField1(2) = "SELECT DISTINCT policy_id"
strField1(3) = "SELECT DISTINCT P.policy_id"
For x = 1 To 150
ArrFnd = Array(strField1(x))
With ActiveDocument
For i = 0 To UBound(ArrFnd)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.MatchWholeWord = True
.Text = ArrFnd(i)
With regexObject
.Pattern = "[SELECT-FROM]"
End With
.Replacement.Text = ""
End With
Do While .Find.Execute
.Font.Shading.BackgroundPatternColorIndex = wdBrightGreen
.Collapse wdCollapseEnd
Loop
End With
Next i
End With
Next x
One wonders why you persist with the approach taken in your code, in light of: MS Word VBA Can't select specific words to change background color
Regardless, for what you are now describing, all you need is:
Sub HiliteWords()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "SELECT[!^13^l]#FROM"
.Replacement.Text = ""
End With
Do While .Find.Execute
.Start = .Words.First.End
.End = .Words.Last.Start - 1
.Font.Shading.BackgroundPatternColorIndex = wdBrightGreen
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
If you also don't want DISTINCT shaded, insert:
If .Words.First.Text = "DISTINCT " Then .Start = .Words.First.End
before:
.End = .Words.Last.Start - 1
I have this regex code and it´s working fine, but I´m trying to manipulate the text inside foreach but is taking no effect at the document.
I want to change the style of the selection and cut the markup off.
Sub Substituir()
Set documento = ActiveDocument.Range
Dim texto As String
Set oRegExp = New RegExp
oRegExp.Pattern = "<h1>[\s\S]*?</h1>"
oRegExp.Global = True
oRegExp.MultiLine = True
Dim resultado As MatchCollection
Set resultado = oRegExp.Execute(documento)
For Each r In resultado
r.Find.Execute FindText:="<h1>", ReplaceWith:="", Replace:=wdReplaceAll
r.Find.Execute FindText:="</h1>", ReplaceWith:="", Replace:=wdReplaceAll
Next
End Sub
The result I´m want is to replace
<h1>bla bla</h1>
with
bla bla
And than change the style to Heading 1 in word.
I would only resort to regex when I cannot achieve what I want with Words built in built in wildcard search.
Option Explicit
Sub Substituir(Optional ByVal this_tag As String = "h1", Optional ByVal this_replacement_style As String = "Heading 1")
With ActiveDocument.Content
With .Find
.ClearFormatting
.Text = "(\<" & this_tag & "\>)(*)(\</" & this_tag & "\>)" ' Default is "(<h1>)(*)(</h1>)"
.Replacement.Text = "\2"
.Format = True
.Replacement.Style = this_replacement_style
.Wrap = wdFindContinue
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
End Sub
I have two sets of data:
1977, 74, 5716-5720, doi:10413454
1967, 8, 8323, doi:10413454
I would like to put the second group, no en dash this set of data marked with yellow. I use my regular expression \d{4}, \d+, \d+(?!-)
But this does not work. Where am I wrong?
Sub Yellow()
Dim p As Paragraph, d As Document, reg As Object
Set d = ActiveDocument
Set reg = CreateObject("VBscript.Regexp")
reg.IgnoreCase = False
reg.Global = True
reg.Pattern = "\d{4}, \d+, \d+(?!-)"
For Each p In d.Paragraphs
If reg.Execute(p.Range.Text).count = 1 Then
m = reg.Execute(p.Range.Text)(0).FirstIndex
n = reg.Execute(p.Range.Text)(0).Length
With d.Range(p.Range.Start + m + 9, p.Range.Start + m + n)
.HighlightColorIndex = wdYellow
End With
End If
Next
End Sub
When applied to the input
1977, 74, 5716-5720, doi:10413454
your regex \d{4}, \d+, \d+(?!-) matches 1977, 74, 571.
Use word boundary anchors to ensure that numbers are always matched in their entirety:
\b\d{4}, \d+, \d+\b(?!-)
Sub Yellow()
With selection.Find
.Text = "[0-9]{4}, [0-9]{1,}, [0-9]{1,}"
.MatchWildcards = True
.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
Do
.Execute
If .Found And selection.Range.Next(wdCharacter, 1) <> "" & ChrW(8211) & "" Then
selection.Range.HighlightColorIndex = wdYellow
End If
If Not .Found Then
Exit Do
End If
Loop
End With
End Sub
I am trying to write a regular expression in VB script to substitute some patterns.
My string may contain zero or more following patterns -
&USERID
&USERID
&USERID.
&USERID.
&USERID(n)
&USERID(n)
&USERID(n).
&USERID(n).
&USERID(n1, n2)
&USERID(n1, n2)
&USERID(n1, n2).
&USERID(n1, n2).
Sample string -
C:\temp\&USERID_&USERID._&USERID(4)_&USERID(2,2)..txt
If USERID=ABCDEF, then once substituted the resultant string should look like -
C:\temp\ABCDEF_ABCDEF_ABCD_BC.txt
The number in the bracket denotes the number of characters to substitute. Range can be specified using comma separated numbers. In order to achieve this I wrote a regular expression as follows -
"((&USERID\(\d+,\d+\)\.)|(&USERID\(\d+,\d+\)\.)|(&USERID\(\d+,\d+\))|(&USERID\(\d+,\d+\)))|((&USERID\(\d\)\.)|(&USERID\(\d\)\.)|(&USERID\(\d\))|(&USERID\(\d\))|(&USERID\.)|(&USERID\.))"
Using VBScript.RegExp I match the pattern and obtain collection of the matches. Iterating over each match object, I substitute either the complete USERID or part of it based on subscript.
The regular expression works fine. BUT it is very slow compared to string manipulation function.
Can above pattern be optimized?
Update:
I accepted the answer which solves one of my problem. Based on the regular expression, I tried to solve another find and replace problem as follows -
I have following patterns
DATE
DATE(MMDDYYYY)
DATE(DDMMYYYY)
DATE(YYYYMMDD)
DATE(YYYY)
DATE(MM)
DATE(DD)
DATE(DDMONYYYY)
DATE(MON)
DATE(MONTH)
DATE(YYDDD)
DATE(YYYYDDD)
It may have a terminating "." at the end.
Function replaceDate(matchString, label, position, sourceString)
If label = "MMDDYYYY" or label = "" then
replaceDate = "<MMDDYYYY>"
ElseIf label = "DDMMYYYY" then
replaceDate = "<DDMMYYYY>"
ElseIf label = "YYYYMMDD" then
replaceDate = "<YYYYMMDD>"
ElseIf label = "YYYY" then
replaceDate = "<YYYY>"
ElseIf label = "MM" then
replaceDate = "<MM>"
ElseIf label = "DD" then
replaceDate = "<DD>"
ElseIf label = "DDMONYYYY" then
replaceDate = "<DDMONYYYY>"
ElseIf label = "MON" then
replaceDate = "<MON>"
ElseIf label = "MONTH" then
replaceDate = "<MONTH>"
ElseIf label = "YYDD" then
replaceDate = "<YYYYDDD>"
Else
replaceDate = ""
end if
End Function
With new RegExp
.Global = True
.IgnoreCase = False
.Pattern = "(?:&(?:amp;)?)?DATE(?:\((MMDDYYYY|DDMMYYYY|YYYYMMDD|YYYY|MM|DD|DDMONYYYY|MON|MONTH|YYDDD|YYYYDDD)?\))?\.?"
strTempValue = .Replace(strTempValue, GetRef("replaceDate"))
End with
Without more data it is not easy to test, but you can try if this performs better
Dim USERID
USERID = "ABCDEF"
Dim originalString
originalString = "C:\temp\&USERID_&USERID._&USERID(4)_&USERID(2,2)..txt"
Dim convertedString
Function replaceUSERID(matchString, n1, n2, position, sourceString)
n1 = CLng("0" & Trim(n1))
n2 = CLng("0" & Trim(Replace(n2, ",", "")))
If n1 < 1 Then
replaceUSERID = USERID
ElseIf n2 > 0 Then
replaceUSERID = Mid(USERID, n1, n2)
Else
replaceUSERID = Left(USERID, n1)
End If
End Function
With New RegExp
.Pattern = "(?:&(?:amp;)?)?USERID(?:\((\s*\d+\s*)(,\s*\d+\s*)?\))?\.?"
.Global = True
.IgnoreCase = False
convertedString = .Replace(originalString, GetRef("replaceUSERID"))
End With
WScript.Echo originalString
WScript.Echo convertedString
For a multiple "label" replacement
Option Explicit
Dim dicLabels
Set dicLabels = WScript.CreateObject("Scripting.Dictionary")
With dicLabels
.Add "USERID", "ABCDEF"
.Add "LUSER", "ABCDEF"
.Add "ID", "GHIJKL"
End With
Dim originalString
originalString = "C:\temp\&USERID_&USERID._&USERID(4)_&USERID(2,2)_ID(2,3)_&LUSER..txt"
Dim convertedString
Function replaceLabels(matchString, label, n1, n2, position, sourceString)
If Not dicLabels.Exists(label) Then
replaceLabels = matchString
Else
n1 = CLng("0" & Trim(n1))
n2 = CLng("0" & Trim(Replace(n2,",","")))
replaceLabels = dicLabels.Item(label)
If n1 > 0 Then
If n2 > 0 Then
replaceLabels = Mid(dicLabels.Item(label), n1, n2)
Else
replaceLabels = Left(dicLabels.Item(label), n1)
End If
End If
End If
End Function
With New RegExp
.Pattern = "(?:&(?:amp;)?)?("& Join(dicLabels.Keys, "|") &")(?:\((\s*\d+\s*)(,\s*\d+\s*)?\))?\.?"
.Global = True
.IgnoreCase = False
convertedString = .Replace(originalString, GetRef("replaceLabels"))
End With
WScript.Echo originalString
WScript.Echo convertedString